perm filename LISP.247[MAC,LSP] blob
sn#251572 filedate 1976-12-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00218 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002
C00010 00003
C00014 00004
C00016 00005
C00018 00006
C00020 00007
C00021 00008
C00024 00009
C00027 00010
C00029 00011
C00032 00012
C00034 00013
C00036 00014
C00038 00015
C00041 00016
C00043 00017
C00045 00018
C00048 00019
C00050 00020
C00052 00021
C00055 00022
C00059 00023
C00062 00024
C00065 00025
C00069 00026
C00072 00027
C00075 00028
C00079 00029
C00082 00030
C00085 00031
C00087 00032
C00091 00033
C00093 00034
C00096 00035
C00099 00036
C00104 00037
C00108 00038
C00110 00039
C00113 00040
C00117 00041
C00120 00042
C00122 00043
C00125 00044
C00128 00045
C00130 00046
C00132 00047
C00134 00048
C00136 00049
C00139 00050
C00143 00051
C00144 00052
C00146 00053
C00148 00054
C00150 00055
C00152 00056
C00154 00057
C00157 00058
C00159 00059
C00160 00060
C00163 00061
C00166 00062
C00169 00063
C00171 00064
C00176 00065
C00178 00066
C00180 00067
C00182 00068
C00184 00069
C00187 00070
C00189 00071
C00191 00072
C00193 00073
C00194 00074
C00196 00075
C00198 00076
C00200 00077
C00203 00078
C00205 00079
C00207 00080
C00209 00081
C00211 00082
C00212 00083
C00214 00084
C00217 00085
C00218 00086
C00220 00087
C00222 00088
C00224 00089
C00228 00090
C00232 00091
C00234 00092
C00238 00093
C00240 00094
C00241 00095
C00243 00096
C00245 00097
C00247 00098
C00250 00099
C00252 00100
C00254 00101
C00258 00102
C00260 00103
C00265 00104
C00268 00105
C00271 00106
C00273 00107
C00275 00108
C00278 00109
C00280 00110
C00284 00111
C00285 00112
C00287 00113
C00290 00114
C00293 00115
C00295 00116
C00297 00117
C00301 00118
C00304 00119
C00309 00120
C00311 00121
C00316 00122
C00319 00123
C00322 00124
C00324 00125
C00326 00126
C00327 00127
C00331 00128
C00333 00129
C00334 00130
C00337 00131
C00340 00132
C00342 00133
C00346 00134
C00348 00135
C00351 00136
C00353 00137
C00356 00138
C00360 00139
C00362 00140
C00364 00141
C00367 00142
C00369 00143
C00371 00144
C00373 00145
C00374 00146
C00376 00147
C00377 00148
C00379 00149
C00382 00150
C00385 00151
C00386 00152
C00390 00153
C00392 00154
C00395 00155
C00397 00156
C00399 00157
C00401 00158
C00403 00159
C00405 00160
C00407 00161
C00409 00162
C00411 00163
C00412 00164
C00414 00165
C00416 00166
C00419 00167
C00421 00168
C00424 00169
C00427 00170
C00430 00171
C00432 00172
C00436 00173
C00438 00174
C00440 00175
C00443 00176
C00445 00177
C00447 00178
C00449 00179
C00451 00180
C00453 00181
C00457 00182
C00460 00183
C00463 00184
C00466 00185
C00470 00186
C00474 00187
C00478 00188
C00480 00189
C00482 00190
C00485 00191
C00487 00192
C00489 00193
C00492 00194
C00494 00195
C00497 00196
C00500 00197
C00502 00198
C00505 00199
C00507 00200
C00509 00201
C00511 00202
C00513 00203
C00516 00204
C00518 00205
C00521 00206
C00524 00207
C00525 00208
C00527 00209
C00531 00210
C00533 00211
C00535 00212
C00537 00213
C00540 00214
C00542 00215
C00544 00216
C00547 00217
C00551 00218
C00552 ENDMK
C⊗;
;;; **************************************************************
;;; ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1976 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
IFE .OSMIDAS-<SIXBIT \ITS\>, .SYMTAB 16001. ;ENSURE ROOM FOR MANY SYMBOLS
.ELSE .SYMTAB 6560.
TITLE ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************
.NSTGWD ;NO STORAGE WORDS PLEASE UNTIL FIRSTLOC
.XCREF A,B,C,AR1,AR2A,T,TT,D,R,F,P,FXP,%
.MLLIT==1
VERSION==.FNAM2 ;BY CONVENTION, THE SIXBIT FOR THE VERSION NUMBER
SUBTTL ASSEMBLY PARAMETERS
IF1,[ ;***** CONDITIONAL ASSEMBLY FLAGS AND PARAMETERS *****
;" FOR ASSLIS - DO NOT PUT ANY OTHER DOUBLE QUOTES ON THIS PAGE
ITS==1 ;FOR RUNNING UNDER THE ITS MONITOR
D10==0 ;FOR RUNNING UNDER DEC SYSTEM 10 MONITOR
SAIL==0 ;FOR RUNNING UNDER SAIL MONITOR
TENEX==0 ;FOR RUNNING UNDER THE TENEX MONITOR
ML==0 ;=1 SAYS THIS LISP IS FOR MATHLAB INSTEAD OF AI
;WHEN RUNNING UNDER THE ITS MONITOR
MOBIOF==0 ;DISPLAY SLAVE, VIDISSECTOR, A/D, D/A, AND PLOTTER ROUTINES FLAG
;WILL GO AWAY WHEN NEWIO MAKES IT FASLOADABLE
BIGNUM==1 ;MULTIPLE PRECISION ROUTINES FLAG
EDFLAG==1 ;ROUTINES FOR LISP EDITOR FLAG
;IF 0, CAUSES EDIT TO HAVE AN AUTOLOAD PROPERTY
OBTSIZ==777 ;LENGTH OF OBLIST
PTCSIZ==40 ;MINIMUM SIZE FOR PATCH AREA
FUNAFL==1 ;FUNARG, FAKE ALIST, AND LABEL STUFF
NEWRD==0 ;NEW READER FORMAT ETC
QIO==0 ;QUUX'S NEWIO STUFF
JOBQIO==1 ;SUPPORT FOR INFERIOR PROCEDURES
NSTAT==1 ;NEW STATUS FUNCTION
HNKLOG==4 ;LOG2 OF SIZE (IN WORDS) OF LARGEST HUNK (0 => NO HUNKS)
USELESS==1 ;NOT PARTICULARLY IMPORTANT FEATURES, LIKE:
; 1) ROMAN NUMERAL READER AND PRINTER
; 2) PRINLEVEL AND PRINLENGTH
; 3) IMPROVED FLOATING POINT PRINTOUT, AND DOUBLE-PRECISION INPUT
; 4) CURSORPOS
; 5) GCD
; 6) DUMPARRAYS, LOADARRAYS
; 7) MACDMP
; 8) RECLAIM, AND RETSP FEATURE WHICH RETURNS BPS CORE TO TS SYSTEM
; 9) PAGE-CLUMPED SUBR-ING [PGTOP]
; 10) PURIFY, AND PURE-INITIAL-READ-TABLE
; 11) IN QIO, CLI INTERRUPT SUPPORT
; 12) IN QIO, MAR-BREAK SUPPORT
; 13) IN QIO, AUTOLOAD PROPERTIES FOR ALLFILES ETC.
; 14) CLEVER TERPRI-BEFORE-THE-PARENS HACK
SEGLOG==11 ;LOG2 OF # OF WORDS PER SEGMENT
;" FOR ASSLIS - DOUBLE QUOTES ARE OKAY NOW
;;; IF1
SUBTTL STORAGE LAYOUTS
;;; STORAGE LAYOUT FOR ITS
;;;
;;; BZERSG 0 - - LOW PAGES
;;; ACCUMULATORS, TEMPORARY VARIABLES,
;;; INITIAL READTABLE AND OBARRAY
;;; BSTSG ST: - - SEGMENT TABLES
;;; BSYSSG FIRSTL: INITIAL SYSTEM CODE (PURE)
;;; BSARSG INITIAL SAR SPACE
;;; BVCSG INITIAL VALUE CELL SPACE
;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG SYMBOL-BLOCKS
;;; BSYMSG SYMBOL-HEADERS
;;; BSY2SG **SYMBOL-BLOCKS
;;; BPFXSG **FIXNUMS
;;; BPFSSG **LIST-STRUCTURE
;;; BPFLSG [**FLONUMS - - POSSIBLY NONE]
;;; BIFSSG LIST-STRUCTURE
;;; BIFXSG FIXNUMS
;;; BIFLSG FLONUMS
;;; BBNSG BIGNUMS
;;; BBITSG BIT BLOCKS FOR GC
;;; BBPSSG START OF BINARY PROGRAM SPACE
;;; C(BPSL) (ALLOC IS IN THIS AREA)
;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS
;;; V(BPEND) ARRAYS START NO LOWER THAN THIS
;;; C(BPSH) LAST WORD OF BPS
;;; ... BINARY PROGRAM SPACE GROWS UPWARD ...
;;; C(HINXM) LAST WORD OF GROSS HOLE IN MEMORY
;;; ... LIST STRUCTURE GROWS DOWNWARD ...
;;; PUSHDOWN LISTS WITH HOLES BETWEEN:
;;; FXP, FLP, P, SP
;;;
;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;;
;;; STORAGE LAYOUT FOR DEC10
;;;
;;; ***** LOW SEGMENT *****
;;; BZERSG 0 - - LOW PAGES
;;; ACCUMULATORS, TEMPORARY VARIABLES,
;;; INITIAL READTABLE AND OBARRAY
;;; BSTSG ST: - - SEGMENT TABLES
;;; BSARSG INITIAL SAR SPACE
;;; BVCSG INITIAL VALUE CELL SPACE
;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG SYMBOL-BLOCKS
;;; BSYMSG SYMBOL-HEADERS
;;; BIFSSG LIST-STRUCTURE
;;; BIFXSG FIXNUMS
;;; BIFLSG FLONUMS
;;; BBNSG BIGNUMS
;;; BBITSG BIT BLOCKS FOR GC
;;; PUSHDOWN LISTS:
;;; FXP, FLP, P, SP
;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;; BBPSSG START OF BINARY PROGRAM SPACE
;;; (ALLOC IS IN THIS AREA)
;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS
;;; V(BPEND) ARRAYS START NO LOWER THAN THIS
;;; C(BPSH) LAST WORD OF BPS (FIXED, SET BY ALLOC)
;;; C(HIXM) HIGH WORD OF EXISTING MEMORY
;;; C(MAXNXM) HIGHEST WORD OF NXM THAT MAY BE USED
;;;
;;; ***** HIGH SEGMENT *****
;;; BSYSSG INITIAL SYSTEM CODE (PURE)
;;; BSY2SG **SYMBOL-BLOCKS
;;; BPFXSG **FIXNUMS
;;; BPFSSG **LIST-STRUCTURE
;;; BPFLSG [**FLONUMS - - POSSIBLY NONE]
;;; BPFSSG INITIAL PURE LIST STRUCTURE
;;; IF1
SUBTTL VARIOUS PARAMETER CALCULATIONS
IFE .OSMIDAS-<SIXBIT \ITS\>,[
DEFINE $INSRT $%$%$%
.INSRT $%$%$% >
PRINTX \ ==> INSERTED: \
$FNAME .IFNM1
PRINTX \ \
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
IFE .OSMIDAS-<SIXBIT \DEC\>,[
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \DEC\>,
IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY???
DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT
ZZX==<FOO>
REPEAT 6,[
IRPNC ZZX←-36,1,1,Q,,[ !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ(\)↑←]
IFSN [Q][ ] PRINTX |Q|
TERMIN
ZZX==ZZX←6
]
TERMIN
;;; IF1
;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
$INSRT DEFNS ;STANDARD AC, UUO, AND MACRO DEFINITIONS
LVRNO==.FNAM2
IFN <LVRNO←-36>-'9, LVRNO==<LVRNO←-6>+<SIXBIT \1\>
PRINTX \VERSION=\ ;PRINT OUT VERSION OF THIS LISP
$FNAME .OFNM2
PRINTX \[\ ;CARRIAGE RETURN
$FNAME LVRNO
PRINTX \]
\
;;; HACK FLAGS AND PARAMETERS
IRP S,,[ITS,D10,SAIL,TENEX,BIGNUM,EDFLAG,FUNAFL,HNKLOG,USELESS
OBTSIZ,SEGLOG,MOBIOF,ML]
INFORM [S=]\S
TERMIN
PRINTC \REDEFINITIONS:
\
.INSRT TTY:
PRINTC \
\
IFE ITS, MOBIOF==0
.ELSE IFE ML, MOBIOF==1
OBTSIZ==OBTSIZ\1 ;MUST BE ODD
IFN QIO,[
NSTAT==1
MOBIOF==0
] ;END OF IFN QIO
IFE QIO, JOBQIO==0
IFN SAIL, D10==1
IFGE HNKLOG-SEGLOG, .FATAL HNKLOG TOO BIG!
;;; CANONICALIZE BITS
IRP X,Y,[ITS,D10,TENEX]
IRP Z,,[Y]
IFN X*Z, .FATAL BOTH X AND Z SPECIFIED
TERMIN
TERMIN
IFE ITS+D10+TENEX, .FATAL SO MAYBE YOU'RE ASSEMBLING FOR THE NULL MACHINE?
;;; IF1
;;; LOSING KL10 HAS A FIX INSTRUCTION
EXPUNGE FIX
IFN ITS,[ ;THIS MUST PRECEDE THE "$INSRT MACS" BELOW
IFNDEF %TOOVR, .INSRT SYSENG;TTY DEFS
] ;END OF IFN ITS
;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
$INSRT MACS ;LOTSA MOBY MACROS
SA% LRCT==210 ;SPACE SUFFICIENT FOR CHARS
SA$ NASCII==1000
SA$ LRCT==1010
IFN ITS, PAGLOG==:12 ;LOG2 OF PAGE SIZE (DAMN WELL BETTER BE 12 FOR ITS!!!
.ELSE PAGLOG==:11 ; SOME CODE ASSUMES IT WILL BE 11 OR 12)
LONUM==400 ;MINIMUM MAGNITUDE OF LOWEST NEGATIVE INUM
HINUM==1000 ;MINIMUM MAGNITUDE OF LARGEST POSITIVE INUM
;SOME CODE ASSUMES HINUM IS AT LEAST 777
;MUCH CODE ASSUMES HINUM IS AT LEAST 177 (FOR ASCII CHARS)
;;; IF1
;;; ALL FLAGS WHICH ARE NON-ZERO MUST BE ONES: SOME CONDITIONAL
;;; ASSEMBLY DOES ARITHMETIC WITH THEM (E.G. FASLOAD; SEE LDFNM2)
IRP FOO,,[ITS,D10,TENEX,ML,MOBIOF,BIGNUM,EDFLAG,FUNAFL
NEWRD,NSTAT,QIO,JOBQIO,USELESS]
IFN FOO, FOO==:1
.ELSE FOO==:0
TERMIN ;USE OF ==: PREVENTS CHANGING THEM
MEMORY==:<1,,0> ;SIZE OF MEMORY!!!
PAGSIZ==:1←PAGLOG ;PAGE SIZE
PAGMSK==:<777777←PAGLOG>&777777 ;MASKS ADDRESSES TO PAGE BOUNDARY
PAGKSM==:PAGMSK#777777 ;MASKS WORD ADDRESS WITHIN PAGE
NPAGS==:MEMORY/PAGSIZ ;NUMBER OF PAGES IN MEMORY
;;; IF1
IFL SEGLOG-7, WARN [SEGLOG=]\SEGLOG,[ IS TOO SMALL (I ASSUME SEGLOG=10)]
.ALSO SEGLOG==10
IFG SEGLOG-PAGLOG, WARN [SEGLOG=]\SEGLOG,[ IS TOO LARGE (I ASSUME SEGLOG=]\PAGLOG,[)]
.ALSO SEGLOG==PAGLOG
SEGLOG==:SEGLOG ;THIS IS THE FINAL VALUE
SEGSIZ==:1←SEGLOG ;SEGMENT SIZE
SEGMSK==:<777777←SEGLOG>&777777 ;MASKS ADDRESSES TO SEGMENT BOUNDARY
SEGKSM==:SEGMSK#777777 ;MASKS WORD ADDRESS WITHIN SEGMENT
NSEGS==:MEMORY/SEGSIZ ;NUMBER OF SEGMENTS IN MEMORY
BTBSIZ==:SEGSIZ/40 ;SIZE OF BIT BLOCKS (ENOUGH BITS FOR A SEGMENT, 40 PER WORD)
SGS%PG==:NSEGS/NPAGS ;NUMBER OF SEGMENTS PER PAGE
BTSGGS==1 ;GUESS AT THE NUMBER OF INITIAL BIT SEGMENTS
IFN ITS,[
ALPDL==4*PAGSIZ ;DEFAULT TOTAL PDL SIZES
ALFXP==4*PAGSIZ
ALFLP==1*PAGSIZ
ALSPDL==2*PAGSIZ
] ;END OF IFN ITS
IFN D10,[
ALFXP==SEGSIZ ;DEFAULT TOTAL PDL SIZES
ALFLP==SEGSIZ
ALPDL==3000
ALSPDL==1400
] ;END OF IFN D10
DEFINE FUMBLIFY LL
IRP TP,,[FFS,FFX,FFL,FFB,FFY,FFH,FFA,PDL,SPDL,FXP,FLP]AL,,[LL]
ZZZ==.IRPCNT
IRP M,,[MIN,MAX]A,,[AL]
M!!TP==A
IFSE M,MAX, IFL ZZZ-6, IFL A-SEGSIZ, M!!TP==SEGSIZ
TERMIN
TERMIN
TERMIN
FUMBLIFY [[0.25,40000],[0.2,14000],[0.15,2*SEGSIZ],[3*SEGSIZ/4,2*SEGSIZ],[SEGSIZ/2,6000],[0,SEGSIZ],[40,SEGSIZ],[200,1400],[100,1400],[200,1000],[20,200]]
FUMBLIFY [[.25,40000],[.25,3000],[.25,SEGSIZ],[.25,SEGSIZ],[SEGSIZ/2,3*SEGSIZ],[0,SEGSIZ],[40,SEGSIZ],[200,1400],[100,1400],[200,1000],[20,200]]
BG% MAXFFB==0
BG% MINFFB==0
;;; BIT POSITIONS IN SEGMENT TABLE WD LH
;;; MUST BE DEFINED BEFORE SKOTT MACRO (Q.V.) CAN BE USED
;;; SEE ALSO PSYMTT
IRPS TP,,[LS=$FS=$FX=$FL=BN=SY=SA=VC=$FXP=$FLP=$XM=$NXM=PUR=HNK=]
TP==1←<21-.IRPCNT>
IFE TP, WARN [TOO MANY ST BITS - TP IS ZERO]
TERMIN
FX==$FX\$FXP
FL==$FL\$FLP
RN==$XM\$NXM
NTYPES==:5+BIGNUM+HNKLOG+1 ;# DATA TYPES, PLUS RANDOM
;;; IF1
;;; ********** INTERRUPT BITS **********
IFN ITS,[
;;; LISP SETS ITS INTERRUPT MASK (.MASK USET VARIABLE) ONLY FROM
;;; THE CONTENTS OF LOCATION INTMSK, WHICH INITIALLY CONTAINS ITSMSK.
;;; DEPOSITING DBGMSK THERE BEFORE STARTUP DISABLES ALL INTERRUPTS
;;; EXCEPT TTY AND PDL OVERFLOW, SO THAT DDT WILL TRAP ILOP, MPV, ETC.
IB.ALARM==200000,, ; REAL TIME CLOCK (ALARM CLOCK)
IB.TIMER==100000,, ; RUN TIME CLOCK
IB.PARITY==1000,, ;+ PARITY ERROR
IB.FLOV==400,, ; FLOATING OVERFLOW
IB.PURE==200,, ;+ PURE PAGE TRAP (WRITE INTO READ-ONLY)
IB.PCPURE==100,, ;+ PURE INSTRUCTION FETCH FROM IMPURE
IB.SYSUUO==40,, ;+ SYS UUO TRAP
IB.AT3==20,, ; ARM TIP BREAK 3
IB.AT2==10,, ; ARM TIP BREAK 2
IB.AT1==4,, ; ARM TIP BREAK 1
IB.DEBUG==2,, ; SYSTEM BEING DEBUGGED
IB.RVIOL==1,, ;+ RESTRICTION VIOLATION (?)
IB.CLI==400000 ; CORE LINK INTERRUPT
IB.PDLOV==200000 ; PDL OVERFLOW
IB.LTPEN==100000 ; LIGHT PEN INTERRUPT
IB.MAR==40000 ;+ MAR INTERRUPT
IB.MPV==20000 ;+ MEMORY PROTECTION VIOLATION
IB.SCLK==10000 ; SLOW CLOCK TICK (.5 SEC)
IB.1PROC==4000 ;* SINGLE INSTRUCTION PROCEED
IB.BREAK==2000 ;* .BREAK EXECUTED
IB.ILAD==1000 ;+ ILLEGAL USER ADDRESS
IB.IOC==400 ;+ I/O CHANNEL ERROR
IB.VALUE==200 ;* .VALUE EXECUTED
IB.DOWN==100 ; SYSTEM GOING DOWN OR BEING REVIVED
IB.ILOP==40 ;+ ILLEGAL INSTRUCTION OPERATION
IB.DMPV==20 ;+ DISPLAY MEMORY PROTECTION VIOLATION
IB.AROV==10 ; ARITHMETIC OVERFLOW
IB.42BAD==4 ;* BAD LOCATION 42
IB.C.Z==2 ;* ↑Z TYPED WHEN THIS JOB HAD TTY
IB.TTY==1 ; INTERRUPT CHAR TYPED ON TTY
Q% ITSMSK=IB<TTY+ILOP+IOC+MPV+PDLOV+TIMER+ALARM+PURE>
Q% DBGMSK=IB<TTY+PDLOV>
] ;END OF IFN ITS
IFN D10,[
IB.PDLOV==200000 ; PDL OVERFLOW
IB.MPV==20000 ;+ MEMORY PROTECTION VIOLATION
] ;END OF IFN D10
;;; IF1
;;; ********** I/O CHANNEL ASSIGNMENTS **********
IFE QIO,[
ERRC==0 ;ERROR MESSAGE CHANNEL
TYIC==1 ;TTY INPUT
TYOC==2 ;TTY OUTPUT
UTIC==3 ;UREAD ("U-TAPE") INPUT (↑Q)
UTOC==4 ;UWRITE OUTPUT (↑R)
LPTC==5 ;LINE PRINTER (↑B) OUTPUT
DSIC==6 ;DISK CHANNEL (USED FOR BOTH INPUT AND OUTPUT)
IFN MOBIOF,[
IPLC==7 ;INTERPRETIVE PLOTTER
VIDC==10 ;VIDISECTOR
NVDC==11 ;FAKE VIDISECTOR
IMXC==12 ;MULTIPLEXER INPUT
OMXC==13 ;MULTIPLEXER OUTPUT
BVDC==14 ;BLOCK VIDI INPUT
DISC==15 ;DISPLAY OUTPUT
SIXC==16 ;PDP-6 CHANNEL (DISPLAY SLAVE)
FTVC==BVDC ;CANT BE USING BOTH FAKE TV AND BLOCK VIDI INPUT
] ;END OF IFN MOBIOF
IFN D10,[
DELC==7 ;RANDOM I/O CHANNEL FOR DEC-10
] ;END OF IFN D10
10% IFE MOBIOF, NOFCH==7 ;NUMBER OF I/O CHANNELS
10% IFN MOBIOF, NOFCH==17
10$ NOFCH==10
] ;END OF IFE QIO
;;; PAGE 376 IS RESERVED FOR COPYING (SEE IP1), AND 377 FOR DISUSE.
;;; (THE DISUSE AS TO DO WITH AN OLD HARDWARE BUG IN BLT.)
;;; ON AI, PAGE 375 IS FOR MAPPING PAGE 0 OF THE DISPLAY SLAVE.
10% Q% P6=MEMORY-3*PAGSIZ ;PAGE 0 OF PDP6 SLAVE IS MAPPED INTO PDP-10 MEMORY
] ;END OF IF1
SUBTTL FIRST LOCATIONS, UUO AND INTERRUPT VECTORS
;IFE <ITS+TENEX>*USELESS, NPGTPS==0
IFE 0, NPGTPS==0
TOPN==0
BOTN==0
.XCREF TOPN BOTN
IFN ITS+TENEX,[
NPURTR==0
Q$ NIOCTR==0
.XCREF PURTR1 NPURTR NIOCTR
] ;END OF IFN ITS+TENEX
N2DIF==0
NPRO==0+1 ;NUMBER OF INTERRUPT PROTECTION REGIONS
;NOTE DEFN OF PRO0 IN MACS FILE
.XCREF NPRO
IFN D10,[
.DECTWO ;DEC TWO-SEGMENT RELOC OUTPUT
%LOSEG==-1 ;INITIALLY START IN LOW SEGMENT
%HISEG==0 ;START AT 0 RELATIVE TO HIGH SEG ORIGIN
] ;END OF IFN D10
IFN ITS, IFDEF .SBLK, .SBLK ;EVENTUALLY FLUSH "IFDEF .SBLK"
.YSTGWD ;STORAGE WORDS ARE OKAY NOW
FIRSTLOC:
IFN D10,[
HILOC==.+400000 ;HISEG STARTS AT 400000
;;; FOR DEC-10, FIRSTLOC AS LOADED WITH RELOCATION MUST BE
;;; STDLO+M*SEGSIZ
;;; AND SIMILARLY HILOC WHEN LOADED MUST BE
;;; STDHI+N*SEGSIZ
;;; FOR INTEGRAL M AND N. INIT WILL ENFORCE THIS IN ORDER
;;; TO PRESERVE SEGMENT BOUNDARIES CORRECTLY.
;;; CURSTD IS THE STDXX FOR WHICHEVER IS THE CURRENT SEGMENT.
STDLO==140 ;SIZE OF JOB DATA AREA
STDHI==10 ;VESTIGIAL JOB DATA AREA
CURSTD==STDLO .SEE $LOSEG
] ;END OF IFN D10
IFN ITS,[
STDLO==0
STDHI==0
CURSTD==0
]
10% BZERSG==0 ;BEGINNING OF "ZERO" SEGMENT(S)
10$ BZERSG==FIRSTLOC-STDLO
LOC 41
JSR UUOH ;UUO HANDLER
10X WARN [TENEX INTERRUPT VECTOR?]
LOC FIRSTLOC
JRST GOINIT
LISPSW: ALLOC ;ALLOC CLOBBERS TO BE "LISP"
IFN ITS,[
TWENTY==:20 ;VARIOUS PLACES OFFSET FROM TWENTY ARE USED BY DDT
THIRTY==:TWENTY+10 ;RECALL THAT THE LEFT HALF OF .40ADDR IS THE ".20ADDR"
;;; ADDRESSES IN THE 20 BLOCK, SWIPED FROM DDT ORDER
;;; 25 HOLDS "." DURING A USER TYPEOUT INSTRUCTION
;;; 26 CONDITIONAL BREAKPOINT INSTRUCTION
;;; 27-30 .BREAK 16,'S FOR RETURNING FROM 26
;;; 31 INSTRUCTION FOR BREAKPOINT WHICH DIDN'T BREAK
;;; 32-33 JRST'S TO PROGRAM FROM 31, OR DATA FOR INSTRUCTION IN 31
;;; 34 INSTRUCTION BEING ≠X'D
.SEE MEMERR
.SEE UUOGL2
;;; 35-36 .BREAK 16,'S FOR RETURNING FROM 34
.SEE $XLOST
.SEE UUOGL2
;;; 37 HOLDS ≠Q DURING A USER TYPEOUT INSTRUCTION
.SEE PSYM1
FORTY: 0 ;.40ADDR USER VARIABLE POINTS HERE
JSR UUOGLEEP ;SYSTEMIC UUO HANDLER
Q% JSR INT ;SYSTEMIC INTERRUPT HANDLER
Q$ -LINTVEC,,INTVEC ;SYSTEMIC INTERRUPT HANDLER
;;; THAT'S SYSTEMIC, NOT NECESSARILY SYSTEMATIC!!!
;;; ITS PASSES THE BUCK TO THE USER ON UUO'S 0 AND 50-77.
;;; THEY TRAP THROUGH THE .40ADDR, NOT NECESSARILY 40;
;;; SINCE LISP TREATS THESE AS ERRORS, WE CAN AFFORD TO SAVE
;;; THE JPC AND OTHER GOODIES HERE.
UUOGLEEP: 0
.SUSET [.RJPC,,JPCSAV]
JRST UUOGL1
JPCSAV: 0
] ;END OF IFN ITS
SUBTTL SFX HACKERY
;;; SFX MACRO TELLS WHERE A LONG PIECE OF SEMI-CRITICAL (MAY BE QUIT
;;; OUT OF, BUT MUST NOT PERMIT USER INTERRUPTS IN) CODE MAY BE MUNGED
;;; IF INTERRUPTED IN THE MIDDLE SO THAT WHEN DONE IT WILL RETURN TO
;;; THE INTERRUPT HANDLER. SUCH CODE INCLUDES ARRAY SUBSCRIPT
;;; COMPUTATIONS (SINCE AN INTERRUPT COULD DISPLACE THE ARRAY)
;;; AND ALL CODE WHICH MODIFIES THE SPECIAL PDL.
NSFC==0 ;COUNTER FOR MACRO SFX
.XCREF NSFC
IFN D10,[
DEFINE SFX A/
SFSTO \.-FIRSTLOC,\NSFC,[A]
NSFC==NSFC+1
A
TERMIN
DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
FIRSTLOC+PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN
] ;END OF IFN D10
IFN ITS,[
DEFINE SFX A/
SFSTO \.,\NSFC,[A]
NSFC==NSFC+1
A
TERMIN
DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN
] ;END OF IFN ITS
;;; THE ZZM AND ZZN MACROS ARE EXPANDED AT SFXTBL (Q.V.)
;;; **** ALL USES OF THE SFX MACRO MUST APPEAR ON THIS PAGE ****
SFXPRO
UNBND2: MOVE TT,(SP)
MOVEM TT,SPSV ;ABOUT LOADING TT WITH SPSV, SEE UNBIND
MOVE TT,UNBND3
SFX POPJ P,
ABIND3: PUSH SP,SPSV
SFX POPJ P,
SETXIT: SUB SP,R70+1
SFX JRST (T)
SPECX: PUSH SP,SPSV
SFX JRST (T)
AYNVSFX: ;XCT'ED BY AYNVER
SFX %WTA (D)
1DIMS: JSP T,AYNV1 ;1-DIM S-EXP ARRAYS COME HERE
ARYGET: ROT R,-1 ;COMMON S-EXP ARRAY ACCESS ROUTINE
ADDI TT,(R)
ARYGT4: JUMPL R,ARYGT8
HLRZ A,(TT)
SFX POPJ P,
ARYGT8: HRRZ A,(TT)
SFX POPJ P,
1DIMF: JSP T,AYNV1 ;1-DIM FULLWORD ARRAYS COME HERE
ANYGET: ADDI TT,(R) ;COMMON FULLWORD ARRAY ACCESS ROUTINE
MOVE TT,(TT)
SFX POPJ P,
NOPRO
SPSV: 0 ;IMPORTANT TO SPECPDL BINDINGS
Q% .SEE INTW0
Q$ .SEE IWAIT
;;; **** THERE MUST BE NO MORE USES OF THE MACRO SFX BEYOND HERE ****
EXPUNGE SFX SFSTO
SUBTTL INTERRUPT FLAGS AND VARIABLES
;;; INTFLG INDICATES WHETHER IN INTERRUPT IS PENDING:
;;; 0 => NO INTERRUPT
;;; -1 => USER INTERRUPT PENDING (STACKED IN INTAR)
;;; -2 => ↑X QUIT PENDING, DON'T RESET TTY
;;; -3 => ↑G QUIT PENDING, DON'T RESET TTY
;;; -6 => ↑X QUIT PENDING, DO RESET TTY
;;; -7 => ↑G QUIT PENDING, DO RESET TTY
INTFLG: 0
;;; MAY NOT ↑G/↑X QUIT OR ALLOW USER INTERRUPTS IF NOQUIT NON-ZERO
;;; NON-ZERO IN LH MEANS GC IN PROGRESS; IMPLIES
;;; PDL POINTERS AND NIL MAY BE CLOBBERED
;;; NON-ZERO ONLY IN RH MEANS PDL POINTERS AND NIL ARE OK
NOQUIT: 0
;;; MAY NOT ALLOW "REAL TIME" INTERRUPTS (CLOCK AND TTY) WHEN
;;; UNREAL IS NON-ZERO. MUNGED BY THE FUNCTION NOINTERRUPT.
;;; 0 => ALL INTERRUPTS OKAY
;;; -1 => NO INTERRUPTS OKAY
;;; 'TTY => ALARMCLOCK OKAY, TTY NOT OKAY
UNREAL: 0
IFE QIO,[
QITC: 0 ;PLACES FOR VARIOUS INTERRUPT-TYPE GUYS TO SAVE ACS
QITD: 0
QITR: 0
] ;END OF IFE QIO
Q$ ERRSVD: 0 .SEE ERRBAD
;;; INTERRUPT MASK IS ALWAYS INITIALIZED FROM THIS WORD. THUS
;;; DEPOSITING INTO IT BEFORE STARTUP CAN AID DEBUGGING (CF. DBGMSK)
10% INTMSK: ITSMSK ;INTERRUPT MASK USED ON STARTUP
10% Q$ INTMS2: ITSMS2 ;MASK WORD 2
10$ SJBENB: 630000 ;INTERRUPT ENABLE MASK
LFAKP==5 ;MUST BE LONG ENOUGH FOR USES BY
LFAKFXP==6 ; PDLOV, ERINIT, AND PURIFY
FAKP: BLOCK LFAKP ;FAKE REGPDL, FOR USE BY PDLOV AND ERINIT
FAKFXP: BLOCK LFAKFXP ;FAKE FIXPDL, FOR USE BY PDLOV AND ERINIT
IFE QIO,[
WAITFL: 0 ;NON-ZERO => INTWAIT IS LETTING AN SFXPRO'ED ROUTINE FINISH
WAITA: 0 ;A TEMPORARY FOR INTWAIT
WAITD2: 0 ;USED BY WAIT TO SAVE .DF2
] ;END OF IFE QIO
;;; IF NON-ZERO, THIS CONTAINS THE ADDRESS OF A USER-SUPPLIED
;;; INTERRUPT PROCESSOR. THE LISP SYSTEM INTERRUPT HANDLER
;;; WILL GIVE IT ANY INTERRUPT LISP DOESN'T PROCESS ITSELF. SEE INT0.
UPIINT: 0
SUBTTL ENTRIES TO VARIOUS ROUTINES CALLED BY JSR
UISTAK: 0 ;STACK UP (ACTUALLY, QUEUE) A USER INTTERRUPT
JRST UISTK1
IFE QIO,[
INTWAIT: 0 ;CHECK TO SEE IF USER INTERRUPT OKAY NOW.
JRST INTW0
SPWR: 0 ;"SPECPDL WINNING RETURN" USED BY INTWAIT TO
JRST SPWR0 ; KEEP SP CONSISTENT. SEE ALSO THE SFX MACRO.
CNTROL: 0 ;PROCESS A CONTROL CHARACTER.
JRST CNTRL1 ;ASCII CODE IS IN ACCUMULATOR A.
IFE D10,[
PDLHAK: 0 ;FIGURE OUT WHICH PDL OVERFLOWED AND FIX IT.
JRST PDLH0 ;IF A NON-ZERO, HAS ADDRESS OF PDL POINTER.
] ;END OF IFE D10
] ;END OF IFE QIO
GCRSR: 0 ;GC RESTORE. CLEANS UP JUST BEFORE AN
JRST GCRSR0 ; ABNORMAL EXIT (GCEND IS NORMAL EXIT).
IFE D10,[
PDLSTH: 0 ;"PDL ST HACK". GETS A NEW PAGE FOR A PDL,
JRST PDLST0 ; AND UPDATES ST AND GCST APPROPRIATELY.
] ;END OF IFE D10
IFN MOBIOF,[
CLZDIS: 0 ;CLOSE THE DIS DEVICE
JRST CLZDS1
DISLEEP: 0 ;SLEEP AND WAIT FOR DISPLAY SLAVE
JRST DISLP1
DISLP2: 0 ;A COUNTER FOR WAITING OUT REQUESTS
] ;END OF IFN MOBIOF
IFN QIO,[
SUBTTL NEWIO I/O CHANNEL ALLOCATION TABLE
;;; ENTRIES:
;;; 1.1-2.9 => ADDRESS OF FILE ARRAY SAR
;;; IF AN ENTRY IS NON-ZERO BUT ITS FILE ARRAY SAR'S
;;; TTS.CL BIT IS SET, THE CHANNEL MAY BE DE-ALLOCATED.
;;; THIS ORDINARILY HAPPENS ONLY ON A QUIT OUT OF $OPEN.
;;; CHANNEL 0 (TMPC) IS PERMANENTLY LOCKED FOR USE OF THE ERR
;;; DEVICE, FOR UPROBE, ETC. NOTE THAT ITS PUTS .OPEN
;;; AND .CALL FAILURE CODES ON CHANNEL 0 ARBITRARILY.
LCHNTB==20
CHNTB:
OFFSET -.
TMPC:: 400000,,NIL ;FIXED TEMPORARY CHANNEL
IFGE LCHNTB-., BLOCK LCHNTB-.
.ELSE WARN [TOO MANY FIXED I/O CHANNELS]
OFFSET 0
;;; DEC-10 I/O BUFFER HEADERS (MUST REMAIN FIXED IN CORE)
IFN D10, REPEAT LCHNTB, CONC BFHD,\.RPCNT,: BLOCK 3
DPAGEL: 60. ;INITIAL DEFAULT PAGEL
DLINEL: 70. ;INITIAL DEFAULT LINEL
IFN JOBQIO,[
LJOBTB==10 ;EIGHT INFERIOR PROCEDURES
JOBTB: BLOCK LJOBTB
] ;END OF IFN JOBQIO
;;; IFN QIO
SUBTTL INITIAL TTY INPUT FILE ARRAY
-F.GC,,TTYIF2 ;GC AOBJN POINTER
TTYIF1: JSP TT,1DIMS
TTYIFA
0 ;CAN'T ACCESS
TTYIF2:
OFFSET -.
FI.EOF:: NIL ;EOF FUNCTION (??)
FI.BBC:: 0,,NIL ;BUFFERED BACK CHARS
FI.BBF:: NIL ;BUFFERED BACK FORMS
TI.BFN:: QTTYBUF ;PRE-SCAN FUNCTION
FT.CNS:: TTYOFA ;ASSOCIATED TTY OUTPUT FILE
BLOCK 3
F.MODE:: FBT<CM>,,2 ;MODE (ASCII TTY IN SINGLE)
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
F.DEV:: SIXBIT \TTY\ ;DEVICE
F.SNM:: 0 ;SNAME/PPN (FILLED IN)
F.FN1:: SIXBIT \.LISP.\ ;FILE NAME 1
F.FN2:: SIXBIT \INPUT\ ;FILE NAME 2
F.RDEV:: BLOCK 4 ;.RCHST'D NAMES
F.FPOS:: -1 ;FILEPOS
TI.ST1:: STTYW1 ;TTYST1
TI.ST2:: STTYW2 ;TTYST2
AT.CHS:: 0 ;CHARPOS
AT.LNN:: 0 ;LINENUM
AT.PGN:: 0 ;PAGENUM
0 ;UNUSED
0 ;UNUSED
BLOCK 6
BLOCK 10
;INTERRUPT FUNCTIONS
FB.BUF::
NIL,,NIL ;↑@ ↑A (SETQ ↑A T)
QCN.BB,,IN0+↑C ;↑B ↑B-BREAK ↑C GC STAT OFF
IN0+↑D,,NIL ;↑D GC STAT ON ↑E
NIL,,IN0+↑G ;↑F ↑G HARD QUIT
REPEAT 3, NIL,,NIL ;↑H-↑M (FORMAT EFFECTORS)
NIL,,NIL ;↑N ↑O
NIL,,NIL ;↑P ↑Q
IN0+↑R,,IN0+↑W ;↑R UWRITE ON? ↑S ↑W INT, ↑V MACRO
IN0+↑T,,NIL ;↑T UWRITE OFF?↑U
IN0+↑V,,IN0+↑W ;↑V TTY ON ↑W TTY OFF
IN0+↑X,,NIL ;↑X SOFT QUIT ↑Y
IN0+↑Z,,NIL ;↑Z GO TO DDT ≠ <ALTMODE>
REPEAT 62, NIL,,NIL ;ALL OTHERS
OFFSET 0
IFN .-TTYIF2-ATIC.SZ, WARN [WRONG LENGTH TTYIF2 (IS ]\.-TTYIF2,[, SHOULD BE ]\ATIC.SZ,[)]
;;; IFN QIO
SUBTTL INITIAL TTY OUTPUT FILE ARRAY
-F.GC,,TTYOF2 ;GC AOBJN POINTER
TTYOF1: JSP TT,1DIMS
TTYOFA
0 ;MAY NOT ACCESS
TTYOF2:
OFFSET -.
FO.EOP:: QTTYMOR ;END OF PAGE FUNCTION
BLOCK 7
F.MODE:: FBT<CM>,,3 ;MODE (ASCII TTY OUT SINGLE) (FBT<SA+CP> FILLED IN)
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
F.DEV:: SIXBIT \TTY\ ;DEVICE NAME
F.SNM:: 0 ;SNAME/PPN (FILLED IN)
F.FN1:: SIXBIT \.LISP.\ ;FILE NAME 1
F.FN2:: SIXBIT \OUTPUT\ ;FILE NAME 2
F.RDEV:: BLOCK 4 ;.RCHST'D NAMES
F.FPOS:: -1 ;FILEPOS
TO.TYP:: 0 ;TTY TYPE (FILLED IN)
ATO.LC:: 0 ;LAST CHAR SWITCH
AT.CHS:: 0 ;CHARPOS
AT.LNN:: 0 ;LINENUM
AT.PGN:: 0 ;PAGENUM
FO.LNL:: 71. ;LINEL
FO.PGL:: 200000,, ;PAGEL
BLOCK 6
OFFSET 0
IFN .-TTYOF2-ATOC.SZ, WARN [WRONG LENGTH TTYOF2]
] ;END OF IFN QIO
SUBTTL SUPER-WRITABLE STUFF - MUST BE SAVED UPON USER INTERRUPT
;;; DONT ALLOW USER INTERRUPTS WHILE:
;;; 1) NOQUIT IS NON-ZERO - THIS PROTECTS GC,
;;; RETSP, SUBLIS, AND OTHERS.
;;; 2) INHIBIT IS NON-ZERO - THIS PROTECTS
;;; MANY AREAS OF SEMI-CRITICAL CODE.
;;; (CF. LOCKI AND UNLOCKI MACROS)
SWS==.
IFE QIO,[
INT: 0
IPCLOK: 0 ;PC LOCATION AT TIME OF INTERRUPT
10% JRST INT0
INTSV: 0 ;INTERRUPT REGISTER SAVED
RDOBCT: 0 ;STALLMAN'S HAC TO STOP RDIN0 WHILE READING FROM TAPE
] ;END OF IFE QIO
IFN QIO,[
;;; INTERRUPT PDL
;;; EACH ENTRY HAS FIVE WORDS PUSHED BY THE SYSTEM, PLUS AC F:
LIPSAV==:6 ;LENGTH OF CRUD PUSHED BY INTERRUPT
IPSWD1==:-5 ;WORD ONE (.PIRQC) INTERRUPTS TAKEN
IPSWD2==:-4 ;WORD TWO (.IFPIR) INTERRUPTS TAKEN
IPSDF1==:-3 ;SAVED .DF1
IPSDF2==:-2 ;SAVED .DF2
IPSPC==:-1 ;SAVED PC
IPSF==:0 ;SAVED ACCUMULATOR F
MXIPDL==4 ;MAX SIMULTANEOUS INTERRUPTS
; (CALCULATED FROM THE DEFER WORDS
; IN THE INTERRUPT VECTOR:
; 1 MISCELLANEOUS
; 2 PDL OVERFLOW
; 1 MEMORY ERROR/ILLEGAL OP
LINTPDL==LIPSAV*<MXIPDL+1> .SEE PDLOV
INTPDL: -LINTPDL,,INTPDL .SEE INTVEC
BLOCK LINTPDL
] ;END OF IFN QIO
;;; THE FOLLOWING STUFF IS SAVED WHEN AN "ERRSET FRAME" IS CREATED.
;;; NOT ONLY ERRSET, BUT ALSO CATCH AND READ NEED TO DO THIS.
;;; INTERPRETED PROGS CREATE A SORT OF HALF-ASSED FRAME.
;;; BEWARE! THE COMPILER DEPENDS ON KNOWING THE LENGTH OF
;;; THE ERRSET FRAME AS A CONSTANT PARAMETER.
ERRTN: 0 ;PDL RESTORATION FOR ERRSET
CATRTN: 0 ;PDL RESTORATION FOR CATCH OF A THROW
EOFRTN: 0 ;PDL RESTORATION ON E-O-F TRAPOUT
PA4: 0 ;PDL RESTORATION ON GO OR RETURN
INHIBIT: 0 ;NON-ZERO => INHIBIT (DELAY) USER INTERRUPTS
ERRSW: -1 ;0 MEANS NO PRINT ON ERROR DURING ERRSET
Q% RRDF: -1 ;LEVEL OF READ: -1=>NONE, 0=>SIMPLE, 1=>RECURSIVE
Q$ BFPRDP: 0 ;LH: FUNCTION WHICH WANTS TTY PRE-SCAN
; (READ, READLINE)
; TYI FOR ACTIVATION AND CURSORPOS
; CLEVERNESS, BUT NO PRE-SCAN
; NIL FOR NO CLEVERNESS AT ALL
;RH: -1 IF WITHIN READ
CATID: NIL ;CATCH IDENTIFICATION TAG
LEP1==.-ERRTN ;***** LENGTH OF SOME OF ERRSET PUSH
.SEE ERSTP
UIRTN: 0 ;NON-ZERO => PDL LOC OF MOST RECENT USER INT FRAME
.SEE UINT0
RSXTB: (A) ;POINTER TO READ SYNTAX TABLE, INDEXED BY A
GCD.A: .SEE GCDBB
PNMK1: .SEE PDLNMK ;SAVE TT
UNBND3: .SEE UNBIND ;SAVE TT
SIXMK2: 0 .SEE SIXMAK
SAVMAR: .SEE SUSP14 ;NEEDN'T BE IN SWS, BUT WHO CARES?
GCD.B: .SEE GCDBB
AUNBD: .SEE AUNBIND ;SAVES D FOR AUNBIND
EXP.S: .SEE EXP ;REMEMBERS SIGN OF ARG
ATAN.S: .SEE ATAN ;SAVES SIGNS OF ARGS <X,,Y>
UNMTMP: ;UNAME TEMP
FPTEM: ;PSYM WANTS THIS TO BE SAME AS PCNT!!!
IFLT9: .SEE IFLOAT ;D SAVED HERE
EQLP: 0 ;PDL POINTER UPON ENTRY TO EQUAL
.SEE EQUAL
GCD.C: .SEE GCDBB
ATAN.X: .SEE ATAN ;TEMPORARY X VALUE
GWDCNT: 0
GCD.D: .SEE GCDBB
ATAN.Y: .SEE ATAN ;TEMPORARY Y VALUE
GWDORG: 0 ;ORIGIN OF LAPPIFICATION - GWDRG1 IS GWDORG-1
GWDRG1: 0
EXPL5: 0 ;TEMP FOR EXPLODE
GCD.UH: .SEE GCDBB
BKTRP: .SEE BAKTRACE
EV0B: .SEE EVAL
FLAT1: .SEE FLATSIZE
MEMV: 0 .SEE MEMBER
UAPOS: ;-1 => UWRITE, >=0 => UAPPEND .ACCESS POS
GCD.VH: .SEE GCDBB
LPNF: ;-1 MEANS NOT A LONG PNAME (FITS IN PNBUF)
.SEE RINTERN
AUNBR: 0 ;SAVES R FOR AUNBIND
DLTC: 0 ;# OF TIMES DELETE/DELQ SHOULD REMOVE ITEM
.SEE DELQ
RINF:
APFNG1:
TABLU1: 0
AUNBF: ;SAVES F FOR AUNBIND
IFE BIGNUM,[
MNMX0: ;"MIN" INSTRUCTION
GRESS0: 0 ;"GREATERP" INSTRUCTION
] ;END OF IFE BIGNUM
IFN BIGNUM,[
GRESS0: 0 ;"MIN" AND"GREATERP" INSTRUCTION
CFAIL: JRST . ;TRANSFER ON FAILURE
CSUCE: JRST . ;TRANSFER ON SUCCEED
] ;END OF IFN BIGNUM
10% IOST: .STATUS 00,A
IFN ITS, SYSCL8:
BACTYF: 0 ;ZERO ON FIRST LOOP THROUGH BACTRACE.
BOOLI: SETZB D,TT ;BOOLEAN INSTRUCTION FOR BOOLE
IFN USELESS, PRINLV: ;<CURRENT PRINT LEVEL>-1
PLUS0: 0 ;TYPE - QFIXNUM OR QFLONUM
IFE BIGNUM,[
PLUS3: ADD D,TT
PLUS6: FAD D,TT ;FLOAT-POINT INSTRUCTION FOR ARITH GENERATOR
] ;END OF IFE BIGNUM
IFN USELESS, ABBRSW: ;KIND OF STUFF DESIRED FROM PRINT0:
; - => ONLY ABBREV STUFF
; 0 => ONLY NON-ABBREV STUFF
; + => BOTH (DISTINGUISHED BY TYOSW)
PLUS8: 0 ;<N,,N> WHERE THERE ARE N ARGS
RM4: 0
IFN USELESS, PRPRCT: ;PRINT'S PARENS COUNTS (LEFT,,RIGHT)
SWNACK: 0 ;USED FOR WNA CHECKING IN STATUS
JRST STAT1
IFN USELESS, TYOSW: 0 ;NORMALLY ZERO - TELLS TYO TYPE OF CHAR
; + => CHAR IS FOR FILES ONLY
; - => CHAR IS FOR TTY ONLY
; 0 => CHAR IS FOR BOTH FILES AND TTY
RDBKBF: 0 ;OCCASIONALLY, A BREAK CHARA HAS TO BE BUFFERED BACK
RDBKC: 0 ;SAVED BREAK CHARACTER, ON EXIT FROM RDCHAR
RDNSV: 0 ;SAVED NUMBER (BEFORE DECIMAL-OR-NOT IS DECIDED)
RDDSV: 0 ;SAVED VALUE OF # OF DIGITS TO RIGHT OF DECIMAL POINT
RDIBS: 0 ;NUMERIC IBASE DURING READING
IFN USELESS, RDROMP: 0 ;ROMANP - ARE ROMAN NUMERALS OK?
RDINCH: 0 ;SOURCE OF CHARACTERS FOR READ
CORBP: 0 ;BYTE-POINTER FOR READ-SOURCE WHEN SOURCE IS BLOCK OF
;ASCII OR SIXBIT STUFF IN CORE
MKNCH: 0 ;INSTRUCTIION FOR MAKNAM TO GET NEXT BYTE
PNBP: 440700,,PNBUF ;BYTE POINTER FOR PNAME BUFF
;;; BUFFER FOR MACDMP/VALRET STRINGS AND JCL. OVERLAPS BIGNUM STUFF.
MAYBE LPNBUF==10
MACOUT: 0
PNBUF: BLOCK LPNBUF
0
JCLBF==PNBUF+1 ;SINCE STATUS JCL MAY CALL INTERN ON A SCO
ATMBF==PNBUF+1 ;DITTO INTERACTION BETWEEN PRINTA AND EXPLODE
IFN BIGNUM,[
REMFL: 0 ;REMAINDER FLAG
VETBL0: 0 ;DIVISION STUFF
DVS1: 0
DVS2: 0
DVSL: 0
DD1: 0
DD2: 0
DD3: 0
DDL: 0
NORMF: 0
QHAT: 0
BNMSV: 0
FACF: 0
FACD: 0
AGDBT: 0
YAGDBT: 0
TSAVE: 0
DSAVE: 0
RSAVE: 0
FSAVE: 0
NRD10FL: 0 ;NOT READING IN BASE 10. FLAG
]
IFG JCLBF+24-., BLOCK JCLBF+24-. ;MUST HAVE AT LEAST 24 WDS
LVLRTS==.-MACOUT ;LENGTH OF VALRET STRING BUFFER
LJCLBF==.-JCLBF
IFE QIO,[
ERROR3: 0 ;PRINT OUT ERROR MESSAGE
JRST EROR3A
ERROR4: 0 ;PRINT OUT FOR OTHER KINDS OF ERRORS
JRST EROR4A
] ;END OF IFE QIO
UUOH: ;KEEP THIS UUO STUFF CONTIGIOUS SO THAT GC CAN SAVE IT.
ERROR: 0
JRST UUOH0
ERBDF: ;SOME RANDOM TEMP FOR UUO HANDLER
UUOFN: 0 ;POINTER TO FUNCTION DURING THE UUOH1 LOOP
UUTSV: 0
UUTTSV: 0
UURSV: 0
UUALT9: .SEE UUALT ;DOESN'T CONFLICT WITH UUPSV
UUPSV: 0
UUOBKG: 0 ;IF IN *RSET MODE, PUT STUFF ON PDL
LUUSV==.-UUOH ;STUFF THAT NEEDS SAVING FOR THE UUO HANDLER
LSWS==.-SWS
JRST UUBKG1
;;; ******** STUFF SAVED UPON USER INTERRUPT ENDS HERE ********
SUBTTL FREE STORAGE LISTS, AND GC AND ALLOC PARAMETERS
;;; ********** FREE STORAGE LISTS **********
;;; THESE ARE USED BY THE VARIOUS CONSERS TO ALLOCATE CELLS OF
;;; THE VARIOUS FREE STORAGE SPACES. NEVER PUT ONE OF THESE IN
;;; A MARKABLE AC (EXCEPT WITHIN A PROPERLY PROTECTED CONSER)!
;;; CAUTION! MUST PRESERVE RELATIVE ORDERING OF
;;; FFS,FFX,FFL,FFB,FFY,FFH,FFA,FFY2
;;; SEE GARBAGE COLLECTOR (GC)
FFS: 0 ;LIST FREE STORAGE LIST
FFX: 0 ;FIXNUMS (AND PNAME WORDS)
FFL: 0 ;FLONUM WORDS LIST
IFN BIGNUM, FFB: 0 ;BIGNUM HEADERS
FFY: 0 ;SYMBOL (PNAME-TYPE ATOM) HEADERS
IFN HNKLOG, FFH: REPEAT HNKLOG, SETZ ;HUNKS
FFA: 0 ;SARS (ARRAY POINTERS)
NFF==:.-FFS ;NUMBER OF FF FROBS
FFY2: SY2ALC ;SYMBOL BLOCKS (EXPLICIT RETURN USED)
;;; SIGN BIT IN FF- MEANS EXEMPT FROM 40-WORD MINIMUM RECLAIMED.
.SEE GCSWH1
.SEE AGC1Q
.SEE GCE0C5
.SEE GCE0C9
.SEE HUNK
;;; MUST PRESERVE RELATIVE ORDERING OF NPFFS THROUGH EPFFB
NPFFS: 0 ;PURE FREE STORAGE COUNTERS
NPFFX: 0
NPFFL: 0
IFN BIGNUM, NPFFB: 0
NPFFY2: 0
EPFFS: 0
EPFFX: 0
EPFFL: 0
IFN BIGNUM, EPFFB: 0
EPFFY2: 0
PSGAOB: 0 ;AOBJN PTR FOR ALLOCATING PURE SEGMENTS
EFVCS: BVCSG+NVCSG*SEGSIZ ;END OF CURRENT VC REGION (EFVCS+NFVCS=LAST USED VC)
NFVCP: NXVCSG/SGS%PG ;NUMBER OF EXTRA VC PAGES
FFVC: BFVCS ;VALUE CELL FREELIST (EXPLICIT RETURN USED)
;;; GCMKL IS ARRANGED LIKE A PROPERTY LIST: THE "PROPERTY NAMES"
;;; ARE SARS, IN DECREASING ORDER OF POSITION IN ARRAY SPACE,
;;; AND THE "PROPERTY VALUES" ARE FIXNUMS DENOTING THE LENGTHS
;;; OF THE ARRAYS. USED BY GC, RETSP, GRELAR, *ARRAY, AND OTHERS
;;; TO KEEP TRACK OF ARRAYS. NOTE: THE INITIAL OBARRAY AND
;;; READTABLE ARE NOT IN GCMKL SINCE THEY ARE NOT IN BPS.
GCMKL: IGCMKL
;;; PROLIS IS AN ALIST USED TO PROTECT NON-ATOMIC READ-MACRO
;;; FUNCTIONS FROM BEING GC'ED. EACH ITEM ON THE
;;; ALIST IS OF THE FORM (FUN RDT . NUM) WHERE:
;;; FUN IS THE FUNCTION TO BE PROTECTED
;;; RDT IS THE SAR OF THE READTABLE CONCERNED
;;; NUM IS A LISP NUMBER (GUARANTEED NLISP INUM)
;;; <ASCII CHAR VALUE> FOR READ-MACRO FUNCTION
;;; PROLIS IS UPDATED BY SSGCPRO AND SSGCREL.
PROLIS: NIL
;;; VARIOUS RANDOM PARAMETERS FOR GARBAGE COLLECTOR
MFFS: MINFFS ;CAUTION!! MUST PRESERVE RELATIVE
MFFX: MINFFX ; ORDERING UP TO (BUT NOT INCLUDING)
MFFL: MINFFL ; PANICP (SEE GC AND OTHERS)
IFN BIGNUM, MFFB: MINFFB
MFFY: MINFFY
IFN HNKLOG, MFFH: REPEAT HNKLOG, MINFFH
MFFA: MINFFA
IFN .-MFFS-NFF, WARN [MFF- TABLE WRONG LENGTH]
NFFS: 0
NFFX: 0
NFFL: 0
IFN BIGNUM, NFFB: 0
NFFY: 0
IFN HNKLOG, NFFH: REPEAT HNKLOG, 0
NFFA: 0
IFN .-NFFS-NFF, WARN [NFF- TABLE WRONG LENGTH]
PANICP: 0 ;-1 SAYS WE'RE CLOSE TO RUNNING OUT OF CELLS
GCMRKV: 0 ;NON-NIL MEANS MARK PHASE ONLY
GCTIM: 0 ;GC TIME
GCTM1: 0
IFN USELESS*QIO*ITS,[
GCWHO1: 0
GCWHO2: 0
GCWHO3: 0
GCWHO: 0
] ;IFN USELESS*QIO*ITS
GCACSAV: BLOCK NACS+1 ;MARKED ACS SAVED HERE
GCNASV: BLOCK 20-<NACS+1> ;UNMARKED ACS SAVED HERE
Q$ GCP=GCACSAV+P
Q$ GCFLP=GCACSAV+FLP
Q$ GCFXP=GCACSAV+FXP ;TEST GCFXP FOR NON-ZERO TO DECIDE IF
Q$ GCSP=GCACSAV+SP ; INSIDE GC AND PDL POINTERS ARE HERE
GCUUSV: BLOCK LUUSV
IRMVF: 0 ;GCTWA REMOVAL OVERRIDE SWITCH
GCRMV: 0 ;WHETHER TO DO GCTWA REMOVAL
ARPGCT: 4 ;# OF PAGES TO GRAB FREELY FOR ARRAYS BEFORE GC
;;; PARAMETERS RELEVANT TO MEMORY ALLOCATION.
;;; MUST PRESERVE RELATIVE ORDERING OF MOST OF THIS STUFF.
;USED BY GC TO HOLD EXACT CALCULATED GCMINS
ZFFS: 0
ZFFX: 0
ZFFL: 0
IFN BIGNUM, ZFFB: 0
ZFFY: 0
IFN HNKLOG, ZFFH: REPEAT HNKLOG, 0
ZFFA: 0
IFN .-ZFFS-NFF, WARN [ZFF- TABLE WRONG LENGTH]
;SIZE OF EACH SWEEPABLE SPACE.
;USED TO CALCULATE PERCENTAGE RECLAIMED.
SFSSIZ: NIFSSG*SEGSIZ
SFXSIZ: NIFXSG*SEGSIZ
SFLSIZ: NIFLSG*SEGSIZ
IFN BIGNUM, SBNSIZ: NBNSG*SEGSIZ
SSYSIZ: NSYMSG*SEGSIZ
IFN HNKLOG, SHNSIZ: REPEAT HNKLOG, 0
SSASIZ: NSARSG*SEGSIZ
IFN .-SFSSIZ-NFF, WARN [S--SIZ TABLE WRONG LENGTH]
;SIZE FOR EACH SPACE BELOW WHICH TO GRAB NEW SEGMENTS FASTLY
; (I.E. WITHOUT DOING A WHOLE GARBAGE COLLECTION FIRST)
GFSSIZ: MAXFFS
GFXSIZ: MAXFFX
GFLSIZ: MAXFFL
BG$ GBNSIZ: MAXFFB
GSYSIZ: MAXFFY
IFN HNKLOG, GHNSIZ: REPEAT HNKLOG, MAXFFH
GSASIZ: MAXFFA
IFN .-GFSSIZ-NFF, WARN [G--SIZ TABLE WRONG LENGTH]
;;; ROOTS OF THE CHAINS LINKING LIKE PAGES IN THE GARBAGE COLLECTOR
;;; SEGMENT TABLE (GCST). FILLED IN AT INIT TIME
FSSGLK: 0
FXSGLK: 0
FLSGLK: 0
BG$ BNSGLK: 0
SYSGLK: 0
IFN HNKLOG, HNSGLK: REPEAT HNKLOG, 0
SASGLK: 0
IFN .-FSSGLK-NFF, WARN [--SGLK TABLE WRONG LENGTH]
S2SGLK: 0 ;THIS MUST FOLLOW THOSE ABOVE!
BTSGLK: 0 ;LINKED LIST OF BIT BLOCKS
IMSGLK: 0 ;LINKED LIST OF IMPURE SEGMENTS (INIT SETS UP)
BTBAOB:
10% -<NBITSG*SEGSIZ/BTBSIZ>+NBITB,,BFBTBS←<5-SEGLOG>
10$ -<NBITSG*SEGSIZ/BTBSIZ>+NBITB,, .SEE IN10S5
MAINBITBLT: BFBTBS-1 ;END ADDRESS FOR BLT OF MAIN BIT BLOCK AREA
GC98: 0 ;RANDOM TEMP FOR GC
GC99: 0 ;RANDOMER TEMP FOR GC
PFSSIZ: NPFSSG*SEGSIZ ;SIZE OF PURE FREE STORAGE AREAS
PFXSIZ: NPFXSG*SEGSIZ ; - USED MAINLY BY STATUS
PFLSIZ: NPFLSG*SEGSIZ
BG$ PBNSIZ: 0 ;AIN'T NO INITIAL PURE BIGNUMS, BABY!
PS2SIZ: NSY2SG*SEGSIZ
;;; ********** HAIRY PARAMETERS HACKED BY ALLOC **********
BPSH: ;BINARY PROG SPACE HIGH
IFE ITS, 0
.ELSE <<ENDLISP+PAGSIZE-1>&PAGMSK>-1
BPSL: BBPSSG ;BINARY PROG SPACE LOS
10% HINXM: 0 ;ADDRESS OF LAST WORD OF NXM HOLE
10$ HIXM: 0 ;ADDRESS OF LAST WORD OF LOW SEGMENT
10$ MAXNXM: 0 ;HIGHEST USABLE WORD OF NXM ABOVE LOW SEGMENT
NPDLL: 0 ;FOR SPECBIND AND PDLNMK (Q.V.)
NPDLH: 0
IFN ITS,[
PDLFL1: 0 ;FOR FLUSHING PDL PAGES - SEE ERINIT
PDLFL2: 0 ;FOR UPDATING ST - SEE ERINIT
] ;END OF IFN ITS
;;; THE NEXT FEW THINGS MUST BE IN THIS ORDER
XFFS: 0 ;MAXIMUM SIZES FOR STORAGE SPACES
XFFX: 0
XFFL: 0
IFN BIGNUM, XFFB: 0
XFFY: 0
IFN HNKLOG, XFFH: REPEAT HNKLOG, MAXFFH
XFFA: 0
IFN .-XFFS-NFF, WARN [XFF- TABLE WRONG LENGTH]
IFN ITS,[
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
XPDL: MAXPDL ;MASTER PDL POSITIONS TO GIVE
XFLP: MAXFLP ; PDL-LOSSAGE INTERRUPTS AT
XFXP: MAXFXP
XSPDL: MAXSPDL
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
ZPDL: MAXPDL ;ACTUAL PDL POSITIONS FOR LOSING
ZFLP: MAXFLP ;INITIALIZED AT ERINIT FROM XPDL ET AL.
ZFXP: MAXFXP ; AND DIDDLED BY PDLOV AT OVERFLOW TIME
ZSPDL: MAXSPDL
] ;END OF IFN ITS
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
C2: -PAGSIZ+NACS+1+2,,PDLORG-1 ;STANDARD REG PDL PTR
FLC2: -PAGSIZ+2,,FLPORG-1 ;STANDARD FLO PDL PTR
FXC2: -PAGSIZ+2,,FXPORG-1 ;STANDARD FIX PDL PTR
SC2: -PAGSIZ+1+2,,SPDLORG ;STANDARD SPEC PDL PTR
ZSC2: SPDLORG ;SC2 WITH ZERO LEFT HALF
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
OC2: 0 ;ABS LIMITS FOR PDLS
OFLC2: 0
OFXC2: 0
OSC2: 0
SUBTTL RANDOM VARIABLES IN LOW CORE
;;; I GUESS THIS STUFF NEED NOT BE CONSIDERED SACRED
Q% MAYBE LINTAR==6
Q$ MAYBE LINTAR==20+10*JOBQIO+5*USELESS ;ENOUGH FOR ALL CHANNELS AND INFERIORS AND USELESS INTERRUPTS
INTAR: 0 ;INDEX INTO INTERRUPT ARRAY (FIFO QUEUE)
BLOCK LINTAR ;ENTRIES OF FORM <INT #,,ARG FOR INT FN>
;RIGHT HALVES ARE PROTECTED BY GC
Q% MAYBE LUNREAR==6
Q$ MAYBE LUNREAR==20+10*JOBQIO+5*USELESS ;ENOUGH FOR ALL CHANNELS AND INFERIORS AND USELESS INTERRUPTS
UNRC.G: 0 ;-2/-3 FOR DELAYED ↑X/↑G INTERRUPT
Q$ IFN USELESS, UNRCLI: 0 ;ENTRY FOR DELAYED CLI INTERRUPT
Q$ IFN USELESS, UNRMAR: 0 ;ENTRY FOR DELAYED MAR INTERRUPT
UNRRUN: 0 ;ENTRY FOR DELAYED RUNTIME ALARMCLOCK
UNRTIM: 0 ;ENTRY FOR DELAYED REAL TIME ALARMCLOCK
UNREAR: 0 ;INDEX INTO "REAL TIME" INTERRUPT QUEUE
BLOCK LUNREAR ;ENTRIES OF FORM <ARG FOR INT FN,,INT #>
;ARGS IN UNREAR NEED NO GC PROTECTION
.SEE NOINTERRUPT
;;; LH OF MUNGP => GC IS IN PROCESS OF USING MARK BITS
;;; IN SARS OR SYMBOLS
;;; RH OF MUNGP => ALIST IS IN PROCESS OF USING LH'S OF
;;; VALUE CELLS FOR SPECPDL HACKERY
;;; ERINIT CHECKS MUNGP AND ATTEMPTS TO RESTORE THINGS IF
;;; NECESSARY. THIS SHOULD HAPPEN ONLY IN THE CASE OF SOME
;;; GROSS BUG LIKE A MEMORY VIOLATION.
MUNGP: 0
BFTMPS==. ;FASLOAD TEMPORARIES
SQ6BIT: 0 ;TEMPORARIES FOR SQUEEZE
SQSQOZ: 0
LDBYTS: 0 ;WORD OF RELOCATION BYTES
LDOFST: 0(TT) ;LOAD OFFSET (RELOCATION FACTOR = VALUE OF BPORG BEFORE LOAD)
LDEOFJ: 0 ;JUMP ADDRESS FOR END OF FASLOAD INPUT FILE
LDAAOB: 0 ;AOBJN INDEX FOR ATOMTABLE ARRAY
LDTEMP: ;RANDOM TEMPORARY
LD6BIT: 0 ;PLACE TO ACCUMULATE SIXBIT WHILE CONVERTING FROM SQUOZE
; - FIRST 6 BITS OF NEXT WORD MUST BE ZERO
LDAPTR: 0(TT) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE ATOMTABLE
LDBPTR: 0(F) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE I/O BUFFER
LDF2DP: 0 ;.FNAM2-DIFFERENT-P (NON-ZERO MEANS FASLAP'S LDFNM2 WAS DIFFERENT FROM CURRENT FASLOAD'S)
LDASAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S ATOMTABLE ARRAY
LDBSAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S I/O BUFFER ARRAY
LDXBLT: 0 ;BLT POINTER FOR ZAPPING CALLS FOR XCTS IN BPS
LDXSIZ: 0 ;0=XCT HACKERY NEVER DONE, -1=DONE AND PURIFIED, N>0=LENGTH (IN WORDS) OF AREA FOR XCTED CALLS
LDXSM1: 0 ;CONTAINS 1 LESS THAN LDXSIZ, AND RETAINS VALUE AFTER LDXSIZ BECOMES -1
LDHLOC: 0 ;HIGHEST LOC ASSEMBLED INTO + 1
LFTMPS==.-BFTMPS ;NUMBER OF FASLOAD TEMPORARIES
10% IUSN: 0 ;INITIAL USER SNAME - SET BY LISPGO
IFE QIO,[
USN: BLOCK 2 ;USER SYSTEM NAME
10% UTOBYT: -1 ;# OF VACANT BYTES LEFT IN UTAPE OUTPUT BUFFER
UTOOPD: 0 ;UTAPE OUTPUT OPENED FLAG (NON-ZERO MEANS TRUE)
UTIOPD: 0 ;UTAPE INPUT OPENED FLAG
UTIN: (SIXBIT \DSK\) ;FOR ITS, HAS MODE BITS IN LH, 3 SIXBIT CHARS FOR DEVICE IN RH
BLOCK 4 ;FOR ITS, USED AS DATA BLOCK ON OPENS
UWRT: 0
] ;END OF IFE QIO
IFN D10,[
IFE QIO,[
UWUSN: 0 ;UWRITE SNAME (I.E. PPN)
D10PTR: 0 ;AOBJN POINTER FOR DEC BUFFERS..
D10ARD: -UTBSIZ,,. ;I/O WORD FOR ARRAY DUMP AND FASL
0
D10NAM: 0 ;THIS WORD ;WILL BE ###LSP WHERE ###=JOB NR
D10REN: BLOCK 2 ;FILE NAME TO
] ;END OF IFE QIO
SYMLO: 0 ;LOW BOUNDARY FOR DDT'S SYMBOL TABLE
UPCOK: -1 ;-1 => TYPING ↑C IS OK. NON-NEG INHIBITS,
; AND CAUSES DELAY OF ↑C INTERRUPTS.
; POS => THERE IS A ↑C REQUEST STACKED UP.
] ;END OF IFN D10
IFE QIO,[
UUN: BLOCK 2 ;UNAME
UFN1: BLOCK 2 ;FN1, LFT BY MOST RECENT UREAD, FASLOAD
UFN2: BLOCK 2
URFN1: BLOCK 2
URFN2: BLOCK 2 ;FN2
SPP: 0 ;PAGE-PAUSE-P PAUSE AT END OF DATAPOINT PAGE IF NON-NIL
SRNLN1: 0 ;SCREEN LENGTH FOR DISPLAY TERMINAL, 0 FOR PRINTING
PAUSFL: 0 ;FLAG TO HANG ON PAUSE FEATURE, -1 TO CONTINUE, +N TO CLEAR SCREEN
STTYSS: 0 ;TTY STATUS WORD
STTYS1: 0 ;TTY INTERRUPT AND WAKEUP CONTROL, FIRST WORD
STTYS2: 0 ; SECOND WORD; MUST FOLLOW FIRST!
TTYDISP: -1 ;TERMINAL TYPE (0 => PRINTING)
LINMODE: SA% NIL ;NON-NIL => LINE BUFFERING MODE (STATUS LINMODE)
SA$ TRUTH
] ;END OF IFE QIO
RDOBJ8: RD8N ;OR RD8W FOR WHITE'S + HAC
ALGCF: 0 ;FLAG TO STOP THE GC WHILE IN ALLOC
AFILRD: -1 ;-1 => NO INIT FILE, >0 => CDR OF ALLOC COMMENT
GNUM: ASCII \G0000\ ;INITIAL GENSYM
;;; RANDOM STUFF FOR RANDOM NUMBER GENERATOR
RNOWS: 36.
RBACK: 71.
RBLOCK: -267233364510 ? 150024234754 ? 3742123646
35711501456 ? 352107676232 ? 50527256770
167457050150 ? -43117344752 ? 334060175522
262357222474 ? 216372106452 ? -243216775730
330162137650 ? -217034631306 ? -112616124724
-320153511274 ? 136777110030 ? -132175077316
142234503276 ? 6001657246 ? -266602313352
-344303247744 ? 43640264406 ? -323622142366
272155266302 ? -342425450266 ? 227626464066
364546575562 ? -356307627720 ? -11354210732
200740776250 ? -10165011334 ? -162161647420
-120575351206 ? 127617717662 ? -164125613224
-17405051702 ? 253370067252 ? -256526020572
-55463531726 ? -246715511012 ? 240267244772
-201055605142 ? 63550073664 ? -333012475562
150133145156 ? -113277052560 ? -25217065400
75437127132 ? -206200652214 ? -320251161276
347117363560 ? -107725100124 ? 35540004440
145373707566 ? 352324550530 ? -173602227164
-254604350106 ? -336734270452 ? 256415642606
164655127254 ? 77346163112 ? 210134701414
136703675276 ? 73775356620 ? 134422373564
-150505346144 ? 265472454540 ? 371055406470
242624146270 ? -322753006552
IFN SAIL,[
ACLKTYP: 0 ;Q$RUNTIME OR QTIME
ATTSV: 0 ;SAVE TT DURING ALAMR
SAINTER: 200,,0 ;NEW STYLE CLOCK INTERRUPT MASK
SAICONT:0 ;CONTINUE POINT FOR INTUUO
SAIALK: 0
SAILJOB: 0
AIPCLOK: 0
0
] ;END OF IFN SAIL
IFN EDFLAG,[
EDPRFL: 0
EDPRN: EDPRW
EDEX2: 0
] ;END OF IFN EDFLAG
IFN MOBIOF,[
NVSCL: 20,, ;SCALING FOR NVFIX - NORMALLY CONVERTS 0 - 37777 TO 0 1777
FTVO: SIXBIT \ &DSK\ ;FAKE TV STUFF
BLOCK 2
CURBLK: 0 ;NUMBER OF BLOCK STORED IN ARRAY POINTED TO BY BUFFER
BUFFER: 0 ;POINTER TO SAR OF BUFFER ARRAY
NFTVBL: 0 ;CURRENT NUMBER OF BLOCKS IN CORE
MFTVBL: 4 ;MAX ALLOWABLE, BEFORE DELETIONS OF BLOCKS IN CORE OCCURS
XBLOKS: 0
YBLOKS: 0
NBLOKS: 0 ;TOTAL NUMBER OF BLOCKS
XLL: 0 ;X LOWER-LEFT
YLL: 0 ;Y "
XUR: 0 ;X UPPER-RIGHT
YUR: 0 ;Y "
NVDCL: 0 ;DIM CUTOFF LEVL
NVCFL: 0 ;CONFIDENCE LEVEL OF IMAGE
NVDK: 0 ;DIM CUTOFF ON FAKETV
ODCL: 0 ;LAST DIM CUTOFF ON FAKETV
PLTTBP: 0 ;BYTE POINTER FOR PLOTTEXT
PLTTBF: 0 ;BUFFER FOR PLOTTEXT
PLTLST: 0 ;CELL FROM WHICH TO DO A PSTRTL
] ;END OF IFN MOBIOF
IFE QIO,[
IFN ITS, URCHST: BLOCK 6 ;FOR UREAD'S .RCHST (READ CHANNEL STATUS)
POV2: . ;ADDRESSES OF ERROR MESAGE FOR PDLOV
LTYOC: 0 ;NON-ZERO => LAST CHAR OUTPUT BY TYO WAS A SLASH
PBFTY: 0 ;CHARACTER BUFFERED UP IN TTY CHANNEL
IFN ITS, IODF1: SIXBIT \↑M !\ ;TO BE USED WHEN A DEVICE FULL MESSAGE NEEDED
] ;END OF IFE QIO
RNTN2: .(T) ;CURRENT PNBUF WORD FOR COMPARE ON INTERN
;;; VARIABLES FOR ARRAY ALLOCATOR
BPPNR: 0 ;<SIZE OF ARRAY HEADER>,,-<SIZE OF ARRAY DATA>
GAMNT: 0 ;NUMBER OF WORDS REQUIRED, ON A CALL TO GETSP
GSBPN: 0 ;USED AS TEMPORARY BPEND WHILE BLT'ING DOWN ARRAYS
ADDSAR: 0 ;ADDRESS OF SPECIAL ARRAY CELL WHEN MAKIN ARRAY
TOTSPC: 0 ;<# OF ARRAY DIMS>,,<TOTAL SPACE NEEDED FOR ARRAY>
LLIP1: 0 ;<LARGEST LEGAL INDEX OF ARRAY>+1
INSP: 0 ;PSEUDO-PDL POINTER FOR ARRAY-ING
RTSP1: 0
RTSP3: 0
LOSEF: 77 ;LAP OBJECT STORAGE - EFFICIENCY FACTOR. FOR (STATUS LOSEF) = N,
;THERE WILL BE <1←N>-1 STORED HERE. SIZE OF GC PROTECTION ARRAY
RWG: 0 ;IF = 0, THEN CREATE ERROR ON DIVIDE BY ZERO,
;OR FLOATING OVFLO ON CONVERSION OF BIGNUM
FLOV9A: 0 ;RANDOM TEMPS FOR FLOATING POINT
FLOV9B: 0 ; OVERFLOW INTERRUPT HANDLER
CPJSW: 0 ;IF NOT ZERO, THEN *RSET WAS ON, AND BAKTRACE WILL FIND MUCH
;INFORMATION FROM THE [FUN,,CPOPJ] TYPE STUFF ON THE PDL
PSYMF: 0 ;NON-ZERO DURING EXECUTION OF PSYM.
POFF: 0 ;VARIOUS ROUTINES INVOLVING $X'S FROM DDT DO JSR'S HERE
JRST PSYM1
PSMS: BLOCK 20 ;THIS SHOULD BE ENOUGH FOR LPSMTB
BLOCK 3
PSMTS: 0
PSMRS: 0
10% SQUOZE 0,. ;FOR A .BREAK 12,[4,,PS.S-1]
PS.S: 0 .SEE PSYM1
IFN <1-QIO>*ITS,[
RD0S3: ASCII \⊂Hλ⊂V\ ;REPOSITION DISPLAY CURSOR
0 ; (↑P H ↑H ↑P V)
] ;END OF IFE QIO
STQLUZ: 0 ;FOR LOSSAGE OF SETQING NIL OR T - REMEMBER WHICH ONE OVER INTWAIT
OLINEL: 0 ;INITIAL SETTING OF LINEL BY TTYOPN (THIS IS AN
; NLISP INUM; HENCE NEEDS NO GC PROTECTION)
NOPFLS: 0 ;NON-ZERO => PURIFY$G SHOULDN'T FLUSH PDLS
10% SAWSP: -1 ;SCREW-AROUND-WITH-SHARING-P
SUBTTL KILHGH AND GETHGH
IFN D10,[
KILHGH: MOVEI A,GETHGH ;KILL HIGH SEGMENT
HRRM A,.JBSA" ;SET START ADDRESS
SA$ SETDDT=047000,,2
SA$ MOVEI A,. ;FOO, HOW MANY WAYS CAN SAIL LOSE?
SA$ SKIPN .JBDDT
SA$ SETDDT A, ;JOBDDT MUST BE NON-ZERO TO SAVE!
MOVSI A,1
SKIPE SGANAM
SKIPN SGADEV
JRST .+3
CORE A, ;FLUSH HIGH SEGMENT
JFCL
EXIT 1, ;CONTINUE
GETHGH: MOVEI A,A+1 ;SET UP TO GET HIGH SEG BACK
MOVE A+1,SGADEV
MOVE A+2,SGANAM
SETZB A+3,A+4
MOVE A+5,SGAPPN
SKIPE SGANAM
SKIPN SGADEV
JRST .+3
GETSEG A, ;GET HIGH SEGMENT
JRST GLSLUZ
JSP F,JCLSET
RETHGH: JRST . ;RETURN ADDR CLOBBERED IN HERE
GLSLUZ: OUTSTR [ASCIZ \?LISP.SHR WENT AWAY
\]
EXIT ;FOO
SGANAM: 0
SGADEV: 0
SGAPPN: 0
SA$ SAILFL: 0
SA$ SAILF2: 0
MAYBE LSJCLBUF==10 ;ENOUGH FOR 40. CHARS
SJCLBUF: 0 ;FIRST WORD HOLD NUMBER OF CHARS BUFFERED
BLOCK LSJCLBUF
0 ;INSURES THAT ILDBS WILL FINALLY SEE A ZERO
] ;END OF IFN D10
SUBTTL INITIAL READTABLE, OBARRAY (IN LOW CORE), AND PURTBL
;;; INITIAL READ SYNTAX TABLE IN FORM OF AN ARRAY
-1,,0 ;IN NEWIO, WILL POINT TO MACRO CHAR LIST
RSXTB1: PUSH P,CFIX1
JSP TT,1DIMF
READTABLE
0
RCT: BLOCK LRCT-2 ;WHICH IS BLT'D IN FROM RCT0
TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE)
NIL,,TRUTH ;(STATUS TERPRI),,(STATUS ←)
;;; INITIAL OBLIST IN FORM OF ARRAY
-<OBTSIZ+1>/2,,IOBAR2
IOBAR1: JSP TT,1DIMS
OBARRAY
OBTSIZ+1+200
IOBAR2: BLOCK <OBTSIZ+1>/2
BLOCK 200/2 ;SINGLE CHAR OBJS TABLE (CREATED AS NEEDED)
;;; PURE PAGE TABLE
;;; CONTAINS TWO BITS FOR EACH PAGE, 16 PAGES PER TABLE WORD
;;; MEANING OF BITS: 00=NXM 01=IMPURE
;;; 10=PURE 11=SPECIAL HACKERY NEEDED
IFN ITS,[
PURTBL:
IF1, BLOCK NPAGS/20
IF2,[
ZZW==. ;DARN WELL BETTER BE SAFE OVER THE FOLLOWING MESS!
.BYTE 2
ZZZ==0
$==3 ;FOR HAIRY PRINTOUT TO WORK
PRINTX \
INITIAL PURTBL MEMORY LAYOUT
[0=NXM, 1=IMPURE, 2=PURE, $=BPS/PDL/SCRATCH]
\
NLBTSG==0
NHBTSG==0
IFN LOBITSG, NLBTSG==NBITSG
.ELSE, NHBTSG==NBITSG
;;; IN THE IRP BELOW, COMMAS AND CR'S MARK GUARANTEED PAGE BOUNDARIES
IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP
IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP
SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$]
ZZX==0
IRPS SPC,,[SPCS]
ZZX==ZZX+N!SPC!SG
TERMIN
REPEAT ZZX/SGS%PG,[
BITS
ZZZ==ZZZ+1
IFE ZZZ&17,[
0
0
]
PRINTX \BITS\
IFE <ZZZ#10>&17, PRINTX \ \
IFE <ZZZ#20>&37, PRINTX \ \
IFE ZZZ&37,[
PRINTX \
\
]
] ;END OF REPEAT
TERMIN
.BYTE
IFN ZZZ-NPAGS,[
WARN \ZZZ,[=WRONG LENGTH FOR PURTBL (SHOULD BE ]\NPAGS,[)]
LOC ZZW
] ;END OF IFN ZZZ-NPAGS
PRINTX \
\
] ;END OF IF2
] ;END OF IFN ITS
SUBTTL OLD I/O BUFFERS, PATCH AREAS
IFE QIO,[
DEFINE OPNWRD A,B,E
O!A!C: IFSE E,, (B+SIXBIT \A\)
IFSN E,, (B+SIXBIT \E\)
A!OPD: 0
TERMIN
OPNWRD LPT,1
IFN MOBIOF,[
OPNWRD IPL,5
OPNWRD NVD,0
OPNWRD BVD,2,NVD
OPNWRD IMX,0
OPNWRD OMX,1
OPNWRD DIS,1
SIXOPD: 0 ;-1 FOR 6, +1 FOR 10 SLAVE
] ;END OF IFN MOBIOF
] ;END OF IFE QIO
CONSTANTS
;;; NO MORE CONSTANTS PERMITTED AFTER THIS IN THE LOSEG (WRITEABLE FIRST PAGE)
IFE QIO,[
IFE D10,[
UTBSIZ==20
ZZ==.
SEGUP .
IFL .-ZZ-2*UTBSIZ-5,[
SEGUP .+1
UTBSIZ==<.-ZZ-6>/2
] ;END OF IFL
LOC ZZ
UTIBP: 440700,,UTIB+UTBSIZ
UTIB: BLOCK UTBSIZ+1
UTOBP: 440700,,UTOB
UTOB: BLOCK UTBSIZ+1
SEGUP .
] ;END OF IFE D10
IFN D10,[
UTBSIZ==200
UTIHED: 0 ;BUFFER HEADER FOR DEC-10 UREAD INPUT
UTIBP: 0
UTIBYT: 0
UTOHED: 0 ;BUFFER HEADER FOR DEC-10 UREAD OUTPUT
UTOBP: 0
UTOBYT: 0
FSLHED: BLOCK 3 ;FOR FASLOAD BUFFER, ETC.
BLOCK 3 ;ROOM FOR FOOLISH HEADER
UTIB: BLOCK UTBSIZ+1
BLOCK 3 ;ROOM FOR FOOLISH HEADER
UTOB: BLOCK UTBSIZ+1
PATCH: BLOCK PTCSIZ
SEGUP .
EPATCH==.-1
LOPATCH==1
] ;END OF IFN D10
] ;END OF IFE QIO
10% LOPATCH==0
10% Q% INFORM [UTAPE BUFFER AREAS=],\UTBSIZ,[ WORDS APIECE]
IF1,[
ZZ==.
LOBITSG==0 ;NON-ZERO ==> BITSGS ARE LOW
PAGEUP
TOP.PG==.
IFGE TOP.PG-ZZ-SEGSIZ,[ ;SEE IF THERE IS ANOTHER SEGMENT LEFT ON THIS PAGE
SEGUP ZZ
SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
SPCBOT BIT
BTBLKS: BLOCK BTSGGS*SEGSIZ-1
SEGUP .
SPCTOP BIT,ST,[BIT BLOCK]
IFE TOP.PG-., LOBITSG==1
.ELSE,[
WARN [LOBITSG STUFF DIDN'T WORK]
EXPUNGE NZERSG NBITSG BBITSG
] ;END OF .ELSE
] ;END OF IFGE TOP.PG-ZZ-SEGSIZ
] ;END OF IF1
IF2,[
10% PAGEUP
10$ SEGUP .
] ;END OF IF2
IFE LOBITSG, SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
10$ EXPUNGE BZERSG
EXPUNGE TOP.PG
SUBTTL SEGMENT TABLES
;;; FORMAT OF SEGMENT TABLE (<NSEGS> WORDS, ONE FOR EACH SEGMENT)
;;; 4.9 LS 1=LIST STRUCTURE, 0=ATOMIC
;;; 4.8 $FS FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;; 4.7 $FX FIXNUM STORAGE (BUT NOT FIXNUM PDL)
;;; 4.6 $FL FLONUM STORAGE (BUT NOT FLONUM PDL)
;;; 4.5 BN BIGNUM HEADER STORAGE
;;; 4.4 SY SYMBOL HEADER STORAGE
;;; 4.3 SA SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO)
;;; 4.2 VC VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;; 4.1 $FXP FIXNUM PDL AREA
;;; 3.9 $FLP FLONUM PDL AREA
;;; 3.8 $XM EXISTENT (RANDOM) AREA
;;; 3.7 $NXM NONEXISTENT (RANDOM) AREA
;;; 3.6 PUR PURE SPACE (ONE OF BITS 4.8-4.5 OR 3.8 SHOULD BE ON)
;;; 3.5 HNK HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO)
;;; 3.4-3.1 UNUSED
;;; 2.9-1.1 ADDRESS OF A DATA TYPE, ATOM:
;;; QLIST, QFIXNUM, QFLONUM, QBIGNUM,
;;; QSYMBOL, QRANDOM, QARRAY, QHUNK<N>
;;; NOTE THAT THESE ATOMS OCCUPY CONSECUTIVE MEMORY
;;; LOCATIONS AND THUS NUMERICALLY ENCODE THE PAGE TYPE.
;;; THIS COMMENT SHOULD BE KEPT CONSISTENT WITH THE IRP
;;; DEFINING THE ABOVE SYMBOLS, AND WITH LOCATION PSYMTT.
SPCBOT ST
ST: ;SEGMENT TABLE
IFE ITS, BLOCK NSEGS ;FOR DEC-10, CODE IN INIT SETS UP THESE TABLES AT RUN TIME.
IFN ITS,[
IF1, BLOCK NSEGS
IF2,[
STDISP: EXPUNGE STDISP ;FOR .SEE
$ST ZER,$XM ;"ZERO" (LOW IMPURE) SEGMENTS
IFN LOBITSG, $ST BIT,$XM ;BIT BLOCKS
$ST ST,$XM ;SEGMENT TABLES
$ST SYS,$XM+PUR ;SYSTEM CODE
$ST SAR,SA ;SARS (ARRAY POINTERS)
$ST VC,LS+VC ;VALUE CELLS
$ST XVC,$NXM ;RESERVED FOR EXTRA VALUE CELLS
$ST IS2,$XM ;IMPURE SYMBOL BLOCKS
$ST SYM,SY ;SYMBOL HEADERS
$ST XXA,$XM ;SLACK SEGMENTS (IMPURE!)
$ST XXZ,$NXM ;SLACK SEGMENTS (INITIALLY NXM)
$ST SY2,$XM+PUR ;PURE SYMBOL BLOCKS
$ST PFX,$FX+PUR ;PURE FIXNUMS
$ST PFS,LS+$FS+PUR ;PURE FREE STORAGE (LIST)
$ST PFL,$FL+PUR ;PURE FLONUMS
$ST XXP,$XM+PUR ;SLACK PURE SEGMENT (FOOEY!)
$ST IFS,LS+$FS ;IMPURE FREE STORAGE (LIST)
$ST IFX,$FX ;IMPURE FIXNUMS
$ST IFL,$FL ;IMPURE FLONUMS
IFN BIGNUM, $ST BN,BN ;BIGNUMS
$ST XXB,$XM ;SLACK SEGMENTS (IMPURE!)
IFE LOBITSG, $ST BIT,$XM ;BIT BLOCKS
$ST BPS,$XM ;BINARY PROGRAM SPACE
$ST NXM,$NXM ;(INITIALLY) NON-EXISTENT MEMORY
$ST FXP,$FXP ;FIXNUM PDL
$ST XFXP,$NXM ;FOR FXP EXPANSION
$ST FLP,$FLP ;FLONUM PDL
$ST XFLP,$NXM ;FOR FLP EXPANSION
$ST P,$XM ;REGULAR PDL
$ST XP,$NXM ;FOR P EXPANSION
$ST SP,$XM ;SPECIAL PDL
$ST XSP,$NXM ;FOR SP EXPANSION
$ST SCR,$NXM ;SCRATCH SEGMENTS
.HKILL ST.ZER
IFN ST+NSEGS-., WARN \.-ST,[=WRONG SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
] ;END OF IF2
] ;END OF ITS
;;; THE FORMAT OF THE GARBAGE COLLECTOR SEGMENT TABLE IS RATHER HAIRY, SINCE
;;; THE SIZES AND POSITIONS OF ALL FIELDS IN EACH WORD ARE DEPENDENT ON THE
;;; SEGMENT SIZE. THE LOW ORDER <22-<SEGLOG-5>> BITS OF EACH ENTRY CONTAIN
;;; THE HIGH-ORDER BITS OF THE ADDRESS OF THE BLOCK OF BITS TO BE USED IN MARKING
;;; THAT SEGMENT. (NOTE THAT THE OMITTED LOW-ORDER BITS OF THIS ADDRESS ARE
;;; ZERO ANYWAY.) THESE ADDRESS BITS ARE IN THIS STRANGE RIGHT-ADJUSTED POSITION
;;; FOR THE CONVENIENCE OF THE GCMARK ROUTINE (Q.V.). NOT ALL SEGMENTS HAVE
;;; BIT BLOCKS; THOSE WHICH DO NOT HAVE A BIT BLOCK HAVE ZERO IN THIS FIELD.
;;; TO THE LEFT OF THIS BIT BLOCK ADDRESS FIELD IS A FIELD OF <22-SEGLOG> BITS;
;;; THIS CONTAINS THE NUMBER OF THE NEXT SEGMENT IN THE TABLE OF THE SAME TYPE.
;;; (NOT ALL SEGMENTS ARE LINKED IN THIS WAY; THOSE SEGMENTS WHICH ARE NOT
;;; LINKED TO ANOTHER ONE HAVE THIS FIELD ZERO.) THE HIGH-ORDER BIT (BIT 4.9)
;;; IS ONE IFF GCMARK SHOULD MARK (NOT NECESSARILY WITH A BIT BLOCK) THE CONTENTS
;;; OF THE SEGMENT. THE BIT 22 BIT POSITIONS TO THE LEFT OF THE HIGH-ORDER
;;; BIT OF THE BIT BLOCK ADDRESS FIELD IS ONE IFF GCMARK SHOULD MARK FROM THE
;;; CDR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY IF BIT 4.9
;;; IS ONE. THE BIT TO THE RIGHT OF THE CDR BIT IS ONE IFF GCMARK SHOULD ALSO
;;; MARK FROM THE CAR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY
;;; IF THE CDR BIT IS ONE. THESE THREE BITS MUST BE IN THESE EXACT POSITIONS,
;;; AGAIN FOR THE CONVENIENCE OF GCMARK (Q.V.). THE OTHER BITS IN EACH WORD
;;; ARE SO ARRANGED AS TO USE UP FREE BITS FROM THE LEFT END OF THE WORD, PACKED
;;; IN AROUND THE THREE BITS ALREADY DESCRIBED. THESE OTHER BITS INDICATE WHETHER
;;; OR NOT THE SEGMENT CONTAINS VALUE CELLS, SYMBOLS, OR SARS.
GCBMRK==400000 ;THESE ARE ALL LEFT HALF FLAGS
GCBCDR==1←<22-<SEGLOG-5>-1>
GCBCAR==GCBCDR←-1
GCB==1,,525252 ;FOR BIT TYPEOUT MODE
ZZZ==400000
GCBFOO==0
IRP NAM,,[VC,SYM,SAR]
ZZZ==ZZZ←-1
IFN ZZZ&GCBCDR, ZZZ==ZZZ←-2
GCB!NAM==ZZZ
GCBFOO==GCBFOO\ZZZ
TERMIN
IFN HNKLOG,[
IFG GCBSAR-GCBCAR, ZZZ==GCBCAR
GCBHNK==0
IRP X,,[4,8,16,32,64,128,256,512,1024]
IFE .IRPCNT-HNKLOG, .ISTOP
ZZZ==ZZZ←-1
CONC GCBH,\.IRPCNT+1,==ZZZ
GCBHNK==GCBHNK\ZZZ
TERMIN ;GCBHNK BITS GUARANTEED CONSECUTIVE AND BELOW GCBCAR
.SEE GCMARK
] ;END OF IFN HNKLOG
GCST: ;GC SEGMENT TABLE
IFE ITS, BLOCK NSEGS ;FOR DEC-10, THE GCST TABLE IS SET UP AT RUN TIME BY INIT.
IFN ITS,[
IF1, BLOCK NSEGS
IF2,[
BTB.==BTBLKS ;LOCATION COUNTER FOR ASSIGNING BIT BLOCKS
$GCST ZER,,,0
IFN LOBITSG, $GCST BIT,,,0
$GCST ST,,,0
$GCST SYS,,,0
$GCST SAR,L,,GCBMRK+GCBSAR
$GCST VC,,,GCBMRK+GCBVC
$GCST XVC,,,0
$GCST IS2,L,,0
$GCST SYM,L,,GCBMRK+GCBSYM
$GCST XXA,L,,0
$GCST XXZ,,,0
$GCST SY2,,,0
$GCST PFX,,,0
$GCST PFS,,,0
$GCST PFL,,,0
$GCST XXP,,,0
$GCST IFS,L,B,GCBMRK+GCBCDR+GCBCAR
$GCST IFX,L,B,GCBMRK
$GCST IFL,L,B,GCBMRK
IFN BIGNUM, $GCST BN,L,B,GCBMRK+GCBCDR
LXXBSG==LXXASG
$GCST1 NXXBSG,XXB,L,,0
IFE LOBITSG, $GCST BIT,,,0
$GCST BPS,,,0
$GCST NXM,,,0
$GCST FXP,,,0
$GCST XFXP,,,0
$GCST FLP,,,0
$GCST XFLP,,,0
$GCST P,,,0
$GCST XP,,,0
$GCST SP,,,0
$GCST XSP,,,0
$GCST SCR,,,0
.HKILL GS.ZER
IFN GCST+NSEGS-., WARN \.-GCST,[=WRONG GC SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
] ;END OF IF2
] ;END OF IFN ITS
PAGEUP
SPCTOP ST,,[SEGMENT TABLE]
10$ $HISEG
10$ HILOC==. ;ORIGIN OF HIGH SEGMENT
10% SPCBOT SYS
SUBTTL BEGINNING OF PURE LISP SYSTEM CODE
PGBOT ERR
BPURPG==. ;BEGINNING OF PURE PAGES FOR INSERT FILE PAGE AND PURIFY
$$$NIL: 777300,,VNIL ;SYMBOL BLOCK FOR NIL
0,,$$NIL ;ALWAYS KEEP ON FIRST PURE SYSTEM PAGE
$INSRT ERROR ;ERROR MSGS AND HANDLERS
;;; ERROR FILE HAS DEFINITION FOR BEGFUN
PGTOP ERR,[ERROR HANDLERS AND MESSAGES]
PGBOT TOP
LISPGO: SETOM AFILRD ;START HERE ON ≠G'ING
10% .SUSET [.S40ADDR,,[TWENTY,,FORTY]] ;SET .40ADDR
10% .SUSET [.RSNAM,,IUSN] ;GET INITIAL SNAME
10$ SETOM UPCOK ;TELL LISP ITS OK TOO
JRST 2,@LISPSW ;ZEROS OUT PROCESSOR FLAGS, AND TRANSFERS TO LISP
LSPRET: MOVE P,C2 ;RETURN TO TOP LEVEL BY ERR, THROW, AND LISP ERRORS
10$ PUSHJ P,SIXJBN
PUSHJ P,ERRPOP
LSPRT1: JSP T,TLVRSS ;RETURN TO TOP BY ↑G
JSP A,ERINIT
10% Q% .SUSET [.SMASK,,INTMSK]
Q$ INTON
Q$ SETZ A, ;NEED ZERO A FOR CHECKU IN NEWIO
PUSHJ P,CHECKU ;CHECK FOR DELAYED "REAL TIME" INTS
MOVEI A,QOEVAL
SKIPE B,VIQUOTIENT ;SHADES OF ERRLIST!!!
CALLF 2,QMAPC
HACENT: PUSH P,FLP .SEE PDLCHK
PUSH P,FXP
PUSH P,SP
PUSH P,LISP1 ;ENTRY FROM LIHAC
PUSH P,[Q.]
Q% SKIPN LINMODE
Q$ JSP F,LINMDP
PUSHJ P,ITERPRI
JRST LISP2 ;KLUDGE SO AS NOT TO MUNG *
SUBTTL BASIC TOP LEVEL LOOP
LISP1: PUSH P,LISP1 ;******* BASIC TOP LEVEL *******
HRRZM A,V. ;THE SYMBOL * GETS AS ITS VALUE THE
PUSH P,A
LISP2: JSP T,TLVRSS ; RESULT OF THE LAST TOP-LEVEL EVAL
POP P,B
SKIPN A,TLF
JRST LISP2A
HRRZ TT,-3(P)
HRRZ D,-2(P)
HRRZ R,-1(P)
PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS
JRST EVAL
LISP2A: MOVEI A,(B)
PUSHJ P,TLPRINT
Q% PUSHJ P,TERPRI
HRRZ TT,-3(P)
HRRZ D,-2(P)
HRRZ R,-1(P)
PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS
Q% PUSHJ P,IREAD ;READ-EVAL-PRINT LOOP OF DEFAULT TOPLEVEL
IFN QIO,[
HRRZ A,VINFILE
SKIPE TAPRED
CAIN A,TRUTH
HRRZ A,V%TYI
MOVE TT,TTSAR(A)
TLNN TT,TTS<TY>
JRST LISP1F
MOVEI TT,FT.CNS
SKIPN AR1,@TTSAR(A)
JRST LISP1F
CAMN AR1,V%TYO
JRST LISP1J
MOVEI TT,F.MODE
MOVE F,@TTSAR(A)
TLNE F,FBT<LN>
JRST LISP1F
LISP1D: TLOA AR1,-1
LISP1J: SKIPA AR1,VOUTFILES
SKIPN TTYOFF
LISP1E: PUSHJ P,TERP1
LISP1F: HRRZ AR1,VINFILE
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
PUSH P,AR1
REPEAT 2, PUSH P,[LISP1G] ;ONCE FOR RANDOM EOF VALUE
MOVNI T,1
JRST IREAD1
LISP1G: POP P,B
CAIE A,LISP1G
JRST LISP1Q
MOVE TT,TTSAR(B) ;SIMPLY TERPRI ON EOF
HRRI TT,FT.CNS ; IF APPROPRIATE
MOVEI AR1,NIL
TLNN TT,TTS<TY>
JRST LISP1E
SKIPN AR1,@TTSAR(B)
JRST LISP1F
CAMN AR1,V%TYO
JRST LISP1J
JRST LISP1D
LISP1Q:
] ;END OF IFN QIO
PUSHJ P,SPCFLS ;MAYBE NEED TO FLUSH A SPACE AFTER READ
;THE BREAK LOOP USES THIS AS A SUBROUTINE
LISP1A: MOVEM A,VIDIFFERENCE ;THE SYMBOL - GETS THE TYPED-IN
MOVEI B,(A) ; EXPRESSION AS ITS VALUE AND KEEPS IT
EXCH B,VIPLUS ;THE SYMBOL + GETS THE THE TYPED-IN
JSP T,SPECBIND ; EXPRESSION AS ITS VALUE, BUT NOT
0 B,VIPLUS ; UNTIL AFTER IT HAS BEEN EVALUATED.
CEVAL: PUSHJ P,EVAL ;SPECBINDING IT ENSURES THAT IT WILL
JUMPE UNBIND ; GET THIS VALUE IN SPITE OF ERRORS.
NILBAD: PUSH P,A ;FOO! WELL, ERROR HANDLING SAVES
PUSH P,CPOPAJ ;ALL ACS IN CASE YOU WANT TO CONTINUE
MOVS A,NIL
SETZM NIL
PUSHJ P,ACONS
%FAC [SIXBIT \NIL CLOBBERED!\]
;;; PUSHJ HERE WITH PROPER VALUES FOR THE RIGHT HALVES
;;; OF <FLP, FXP, SP> IN <TT, D, R>. WILL ERROR OUT
;;; IF THEY DON'T MATCH UP. USED FOR TRAPPING GROSS
;;; ERRORS IN THE SYSTEM.
PDLCHK: SETZ T,
CAIE TT,(FLP)
MOVEI T,QFLPDL
CAIE D,(FXP)
MOVEI T,QFXPDL
CAIE R,(SP)
MOVEI T,QSPECPDL
JUMPE T,CPOPJ ;EVERYBODY HAPPY?
PDLCRP: MOVEI A,(T) ;NO, PDL CRAP-OUT
LER3 [SIXBIT \OUT OF PHASE (SYSTEM ERROR)!\]
IFN QIO,[
;;; SKIP IF INPUT FILE IN LINE MODE.
;;; ALSO LEAVE OUTFILES IN AR1 AND READTABLE IN AR2A.
;;; FURTHERMORE LEAVE INPUT FILE IN C (SEE TLPRINT).
;;; ALSO LEAVE TTSAR OF INPUT FILE IN T.
LINMDP: JSP T,GTRDTB
HRRZ C,VINFILE
SKIPE TAPRED
CAIN C,TRUTH
HRRZ C,V%TYI
MOVEI TT,F.MODE
MOVE T,@TTSAR(C)
SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
TLNN T,FBT<LN>
JRST (F) ;TYPICALLY RETURN TO AN ITERPRI
JRST 1(F) ; OR SKIP OVER IT
] ;END OF IFN QIO
TLPRINT: PUSH P,A ;TOP-LEVEL PRINT
Q% SKIPN LINMOD
Q% PUSHJ P,ITERPRI
IFN QIO,[
JSP F,LINMDP ;LEAVES INPUT FILE IN C
JRST TLPR1
MOVEI TT,FT.CNS
HRRZ C,@TTSAR(C)
TLNE T,TTS<TY>
CAME C,V%TYO
TLPR1: PUSHJ P,ITERPRI
] ;END OF IFN QIO
MOVE A,(P)
PUSHJ P,IPRIN1
MOVEI A,40
PUSHJ P,TYO
JRST POPAJ
IPRIN1:
Q% SKIPN VPRIN1
Q$ SKIPN V%PR1
JRST PRIN1
Q% JCALLF 1,@VPRIN1
Q$ JCALLF 1,@V%PR1
;;; TOP LEVEL VARIABLE SETTINGS
TLVRSS: MOVE A,[PNBUF,,PNBUF+1]
SETZM PNBUF
BLT A,PNBUF+LPNBUF-1
TLVRS1: PUSH P,EOFRTN
Q% MOVE A,[INTSV,,INTSV+1]
Q% SETZM INTSV
Q$ MOVE A,[INTPDL+1,,INTPDL+2]
Q$ SETZM INTPDL+1
BLT A,ERRTN+LEP1-1
POP P,EOFRTN
SETZB NIL,PANICP
SETZB A,PSYMF
SETZB B,EXPL5
SETZB C,PA3
Q% SETZB AR1,MKNM3
Q$ SETZB AR1,RDLARG
SETZB AR2A,QF1SB
SETZM ARGLOC
SETZM ARGNUM
SETOM ERRSW
Q% SETOM RRDF
Q$ SETZM BFPRDP
JRST (T)
IFN D10,[
SIXJBN: PJOB B,
IDIVI B,10.
MOVSI D,20(C)
IDIVI B,10.
MOVSI A,202000
LSH B,12.+18.
LSH C,6.+18.
ADD A,B
ADD A,C
ADD A,D
HRRI A,(SIXBIT /LSP/)
MOVEM A,D10NAM ;SAVE ###LSP AS TEMP FILE NAME
POPJ P,
] ;END OF IFN D10
SUBTTL INITIALIZATION ON ↑G QUIT AND ERRORS
;;; ERINIT RESETS PDL POINTERS, THEN FALLS INTO ERINI0.
;;; ERINI0 RESETS VARIOUS VARIABLES AND PERFORMS CLEANUP.
ERINIT:
IFE ITS,[
MOVE P,C2 ;SET UP PDL POINTERS
MOVE FXP,FXC2
MOVE FLP,FLC2
MOVE SP,SC2
] ;END OF IFE ITS
.ELSE,[
PIOF
MOVE T,PDLFL1 ;CONTAINS <- # OF PDL PAGES,,# OF 1ST PDL PAGE>
.CALL PDLFLS ;FLUSH ALL PDL PAGES
.VALUE
MOVE T,[$NXM,,QRANDOM]
MOVE TT,PDLFL2 ;CONTAINS <- # OF PDL SEGS,,# OF 1ST PDL SEG>
MOVEM T,ST(TT) ;UPDATE SEGMENT TABLE TO REFLECT
AOBJN TT,.-1 ; LOSS OF PDL PAGES
HRRZ T,PDLFL1
ROT T,-4
ADDI T,(T)
ROT T,-1
TLC T,770000
ADD T,[450200,,PURTBL]
SETZ D,
HLRE TT,PDLFL1
ERINI8: TLNN T,730000
TLZ T,770000
IDPB D,T
AOJL TT,ERINI8
MOVEI AR2A,(A)
IRP Z,,[P,FLP,FXP,SP]
Q% MOVEI A,Z
Q$ MOVEI F,Z
MOVE Z,C2-P+Z ;CAUSE ONE PDL PAGE
MOVEI D,1(Z) ; FOR Z TO EXIST
ANDI D,PAGMSK
JSR PDLSTH .SEE PDLST0
TERMIN
MOVEI A,(AR2A)
ERIN8G: MOVE T,[XPDL,,ZPDL]
BLT T,ZSPDL
] ;END OF .ELSE
ERINI0: SETZB NIL,TAPRED ;INITIALIZATION AFTER PDL SETUP
SETZM NOQUIT
SETZM FASLP
IFN USELESS, SETZM TYOSW
SETZM INTFLG
SETZM INTAR
SETZM VEVALHOOK
Q% SETZM TYIMAN
Q% SETZM TMBBC
Q% SETZM RDTYBF
IFN QIO,[
SETZM GCFXP ;NON-ZERO WOULD MEAN INSIDE GC
SETZM BFPRDP
MOVE T,[-LINTPDL,,INTPDL]
MOVEM T,INTPDL
;; MOVEI T,READP
;; MOVEM T,READPMAN
;; MOVEI T,UNRD
;; MOVEM T,UNREADMAN
IRP X,,[TYIMAN,UNTYIMAN]Y,,[$DEVICE,UNTYI]
MOVEI T,Y
MOVEM T,X
TERMIN
] ;END OF IFN QIO
;FALLS THROUGH
;FALLS IN
ERINI2: SKIPL MUNGP ;MAYBE NEED TO UNMUNG SYMBOLS AND SARS
JRST ERINI6
MOVE D,SYSGLK
ERINI5: JUMPE D,ERIN5A
MOVEI F,(D)
LSH F,SEGLOG
HRLI F,-SEGSIZ
LDB D,[SEGBYT,,GCST(D)]
ERIN5C: MOVSI R,1
ANDCAB R,(F) ;UNMUNGS THE SYMBOL HEADER, IF NECESSARY
HLRZS R
HRRZ R,(R) ;GET ADDR OF VALUE CELL
CAIL R,BVCSG
CAIL R,BVCSG+<NXVCSG+1>*SEGSIZ
JRST .+2
JRST ERIN5D
CAIL R,BPURFS
CAIL R,PFSLAST
JRST .+2
JRST ERIN5D
HRRZS (R) ;UNMUNGS THE VALUE CELL, IF STORED IN LIST SPACE
ERIN5D: AOBJN F,ERIN5C
JRST ERINI5
ERIN5A: MOVE F,[SARTOB,,B]
BLT F,LPROGZ
MOVE D,SASGLK
ERIN5B: JUMPE D,ERINI6
MOVEI F,(D)
LSH F,SEGLOG
HRLI F,-SEGSIZ/2
LDB D,[SEGBYT,,GCST(D)]
JRST SATOB1
ERINI6: HRRZS MUNGP
SKIPN MUNGP ;UNMUNG VALUE CELLS (SEE ALIST)
JRST ERIN6A
MOVEI F,BVCSG
SUB F,EFVCS
HRLI F,(F)
HRRI F,BVCSG
HRRZS (F)
AOBJN F,.-1
SETZM MUNGP
ERIN6A: MOVE B,[ERRTN,,ERRTN+1]
SETZM ERRTN
BLT B,UIRTN
Q% SETOM RRDF
SETOM ERRSW
MOVSI B,-NSFC
ERINI3: MOVE C,SFXTBI(B) ;RESTORE CLOBBERED LOCATIONS
MOVEM C,@SFXTBL(B)
AOBJN B,ERINI3
Q% SETZM WAITFL ;IS EVERYBODY HAPPY?
TLZ A,-1
PION
10X WARN [PION IN ERINIT?]
JRST (A)
SARTOB: ;TURN OFF MARK BITS IN SARS
OFFSET B-.
SATOB1: ANDCAM SATOB7,TTSAR(F)
AOBJP F,ERIN5B
AOJA F,SATOB1
SATOB7:
TTS<GC>,,
LPROGZ==.-1
OFFSET 0
.HKILL SATOB1 SATOB7
PDLFLS: SETZ
SIXBIT \CORBLK\
1000,,0 ;DELETE PAGES...
1000,,-1 ; FROM MYSELF...
SETZ T ; AND HERE'S HOW MANY AND WHERE!
SUBTTL SPECIAL VARIABLE BINDING AND UNBINDING ROUTINES
JFCL ;HISTORICAL LOSS -- EVENTUALLY FLUSH
SPECBIND: MOVEM SP,SPSV ;0 0,FOO MEANS FOO IS ADDR OF SVC TO BE BOUND TO NIL
SPEC1: LDB R,[271500,,(T)] ;0 N,FOO MEANS SVC FOO TO BE BOUND TO CONTENTS OF ACC N
JUMPE R,SPEC4
CAILE R,17 ;7←41 M,FOO MEANS BIND FOO TO -M(P)
JRST SPEC3 ;OTHERWISE, IS PDP10 INSTRUCTION, SO EXIT
SPEC2: HRRZ R,(R) ;NOTE WELL! NCOMPLR DEPENDS ON THE FACT
CAML R,NPDLL ; THAT R = TT+2 = NUMVALAC+2
CAMLE R,NPDLH
JRST SPEC4
PUSH FXP,T
MOVEI T,(R)
LSH T,-SEGLOG
SKIPL T,ST(T) ;NMK1 WILL WANT TYPE BITS IN T
TLNN T,$FXP+$FLP
JRST SPEC5
HRR T,(FXP)
LDB R,[271500,,(T)] ;RECOMPUTE ADDRESS OF FROB
CAIG R,17
JRST SPEC6
TRC R,16000#-1
ADDI R,1(P)
SPEC6: PUSHJ P,ABIND3 ;TEMPORARILY CLOSE THE BIND BLOCK
PUSH P,A
HRRZ A,(R)
PUSHJ P,NMK1
MOVEM A,(R) ;CLOBBER LOC OF FROB WITH NEW NUMBER
CAIN R,A ;GRUMBLE
MOVEM A,(P)
SUB SP,R70+1 ;SO RE-OPEN THE BIND-BLOCK
MOVEI R,(A) ;THEREBY INHIBITING INTERRUPTS
POP P,A
SPEC5: POP FXP,T
SPEC4: EXCH R,@(T)
HRL R,(T)
PUSH SP,R
AOJA T,SPEC1
SPEC3: CAIGE R,16000
JRST SPECX
TRC R,16000#-1 ;RH OF R NOW HAS N
ADDI R,1(P) ;SPECBINDING OFF PDL
JRST SPEC2
ERRPOP: SKIPA TT,ZSC2 ;TOTALLY POP OFF SPECPDL FOR ERRORS
UBD0: TLZA TT,-1 ;POP SPECPDL TO PLACE SPECIFIED IN TT
SETOM (TT) ;ERRPOP MUST SETOM - SEE UBD4
UBD: CAIL TT,(SP) ;RESTORE THE SPDL BY RESTORING VALUES
JRST UNBND2 ;UNTIL (SP) MATCHES (TT)
POP SP,R
HLRZ D,R
TLZ R,-1
CAMGE R,ZSC2
JRST UBD3
CAIG R,(SP)
IFE FUNAFL, JRST UBD
IFN FUNAFL,[
JRST UBD4
JUMPN D,UBD3
.VALUE ;SOMEBODY SCREWED THE SPECPDL - HELP!!!
] ;END OF IFN FUNAFL
UBD3: HRRZM R,(D)
UBD1: JRST UBD
IFN FUNAFL,[
UBD4: HLRZ D,(SP)
JUMPN D,UBD ;AMONG OTHER THINGS, ERRPOP'S SETOM MAKES THIS JUMP
PUSH FXP,T ;MUST SAVE T
MOVEI T,(R)
PUSHJ P,AUNBN0 ;FOUND A FUNARG BINDING BLOCK
POP FXP,T ; - USE SPECIAL ROUTINE TO UNBIND IT
JRST UBD
] ;END OF IFN FUNAFL
UNBIND: POP SP,T
MOVEM TT,UNBND3 ;HORRIBLE HACK TO SAVE AC TT. THINK ABOUT THIS SOME DAY
UNBND0: TLZ T,-1 ;AUNBIND ENTERS HERE
UNBND1: CAIN T,(SP)
JRST UNBND2
POP SP,TT
MOVSS TT
HLRZM TT,(TT)
JRST UNBND1
;;; BIND, AND MAKE-VALUE-CELL ROUTINES.
;;; PUSHJ P,BIND WITH SYMBOL IN A, VALUE IN AR1.
;;; USES ONLY A, TT; MUST SAVE T
;;; JSP TT,MAKVC WITH AN ATOMIC SYMBOL ON THE PDL (WHICH IS POPPED)
;;; AND THE VALUE IN B. RETURNS ADDRESS OF NEW VALUE CELL IN A.
;;; (LATTER CROCK FOR BIND1 ONLY). USES ONLY A,B,TT.
BIND: SKIPN TT,A
JRST BIND5
HLRZ A,(A)
XCTPRO
HRRZ A,(A)
NOPRO
CAIN A,SUNBOUND
JRST BIND1
BIND4: PUSH SP,(A)
HRLM A,(SP)
STQPUR: HRRZM AR1,(A)
POPJ P,
BIND5: MOVEI A,VNIL ;ALLOW PURPGI TRAP TO WORK JUST
CBIND4: JRST BIND4 ;LIKE FOR SETQING T
BIND1: PUSH P,CBIND4 ;SET UP FOR CALL TO MAKVC
PUSH P,B
PUSH P,TT
MOVEI B,QUNBOUND
JSP TT,MAKVC
POPBJ: POP P,B
CPOPBJ: POPJ P,POPBJ
MAKVC: PUSH FXP,TT ;SAVE RETURN ADDR
SPECPRO INTZAX
MAKVC0: SKIPN A,FFVC
JRST MAKVC3
EXCH B,@FFVC
XCTPRO
HRRZM B,FFVC
NOPRO
MAKVC1: HLRZ B,@(P) ;POINTER TO SYMBOL HEADER IS ON STACK
PURTRAP MAKVC9,B, HRRM A,(B)
MAKVCX: SUB P,R70+1 ;POP POINTER, RETURN ADDRESS OF VALUE CELL
POPJ FXP,
IFE ITS,[
MAKVC3: PUSHJ P,CONS1
JRST MAKVC1
] ;END OF IFE ITS
SUBTTL VARIOUS ODDBALL CONSERS
IFN BIGNUM,[
C1CONS: EXCH T,YAGDBT
JSP T,FWCONS
EXCH T,YAGDBT ;FALL INTO ACONS
] ;END OF IFN BIGNUM
BAKPRO
ACONS: SKIPN FFS ;THIS IS A CONS LIKE XCONS
PUSHJ P,AGC ;BUT USES ONLY ACCUMULATOR A
MOVSS A ;SWAP HALVES OF A, THEN
SPECPRO INTACX
EXCH A,@FFS ;CONS WHOLE WORD FROM A
XCTPRO
EXCH A,FFS
NOPRO
POPJ P,
IFN BIGNUM,[
BAKPRO
BGNMAK: ;MAKE A POSITIVE BIGNUM (SAME AS BNCONS)
BNCONS: SKIPN FFB ;BIGNUM CONSER
PUSHJ P,AGC
EXCH A,@FFB
XCTPRO
EXCH A,FFB
NOPRO
POPJ P,
] ;END OF IFN BIGNUM
SIXMAK: MOVSI TT,(SIXBIT \@\) ;"CONSS" UP SIXBIT FROM ASCII
MOVEM TT,SIXMK2
MOVE AR1,[440600,,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA
MOVE TT,SIXMK2
POPJ P,
SIXMK1: CAIGE A,140 ;THIS SAYS CONVERT LOWER CASE TO UPPER
TRC A,40 ;CONVERT CHAR TO SIXBIT
TLNE AR1,770000
.UDT4: IDPB A,AR1 ;MAYBE SAVE IT, UNLESS ALREADY HAVE SIX
POPJ P,
SUBTTL CATCH, THROW, ERRSET, .SET, AND BREAK ROUTINES
CATPUS: PUSH P,B
CATPS1: MOVEM A,CATID
JSP T,ERSTP
MOVEM P,CATRTN
JRST (TT)
THROW5: SKIPE D,UIRTN ;IF NO USER INTERRUPT FRAME STACKED,
CAIG D,(TT) ; OR IF IT IS BELOW THE CATCH FRAME,
JRST THROW3 ; THEN JUST EXIT THE CATCH FRAME
JSP TT,UIBRK ;OTHERWISE BREAK OUT OF THE INTERRUPT
THROW1: SKIPN TT,CATRTN ;SKIP IF CATCH FRAME BELOW US
JRST THROW4
JUMPE B,THROW5
THROW6: SKIPE T,(TT) ;(CATCH FOO NIL) = (CATCH FOO)
CAIN B,(T)
JRST THROW5 ;CATCH ID MATCHES THROW ID
MOVE TT,<-LEP1+1>+<CATRTN-ERRTN>(TT) ;GO BACK ONE CATCH
JUMPN TT,THROW6 ;FALL THROUGH IF NO MORE
THROW7: EXCH A,B
%UGT EMS29
EXCH A,B
JRST THROW1
THROW4: JUMPN B,THROW7 ;NO CATCH FRAME -- GIVE UGT EROR
JRST LSPRET ;IF NO THROW TAG, THROW TO TOP LEVEL
JRST THROW1 ;COMPILED THROWS COME HERE
ERUNDO: SKIPN ERRTN ;COMPILED ERR, AND NORMAL ERRSET EXIT COMES HERE
JRST LSPRET ;RETURN TO TOPLEVEL
ERR0:
IFN USELESS, SETZM TYOSW
JUMPN A,ERUN0 ;ELSE, BREAK UP AN ERRSET
SKIPE V.RSET
SKIPN VERRSET ;ERRSET BEING BROKEN BY AN ERROR
JRST ERUN0
PUSH P,A
Q% MOVEI A,ERSTBK
Q$ MOVEI D,1001 ;ERRSET USER INTERRUPT
PUSHJ P,UINT
POP P,A
JRST ERUN0
SKIPA TT,CATRTN ;PHOOEY, COMPILED CODE COMES HERE WHEN A
GOBRK: MOVE TT,ERRTN ;GO OR RETURN OCCURS WITHIN AN ERRSET OR CATCH
JUMPE TT,ER4
EXCH T,-LERSTP(TT)
THROW3: MOVE P,TT
JRST ERR1
IOGBND: JSP T,SPECBIND ;BIND ALL I/O CONTROL VARIABLES TO NIL:
TTYOFF ; ↑W
TAPRED ; ↑Q
TAPWRT ; ↑R
Q% LPTON ; ↑B
IFN MOBIOF, DISPON ; ↑F
EPOPJ: POPJ P,
;;; MOVEI D,LOOP ;ROUTINE TO LOOP
;;; PUSHJ P,BRGEN
;;; GENERATES A BREAK LOOP SURROUNDED BY A CATCH AND AN
;;; ERRSET. ERRORS CAUSE THE LOOP TO BE RE-ENTERED.
;;; BRGEN RETURNS WHEN THE LOOP ROUTINE PERFORMS A
;;; THROW TO THE TAG BREAK.
BRGEN: MOVEI A,QBREAK ;CATCH ID = BREAK
JSP TT,CATPS1 ;SET UP CATCH FRAME
PUSH P,D
PUSH P,. ;RETURN POINT FOR ERROR
JSP T,ERSTP ;SET UP ERRSET FRAME
SETOM ERRSW
MOVEM P,ERRTN
JRST @-LERSTP-1(P) ;CALL RANDOM ROUTINE
;;; BREAK LOOP USED BY *BREAK
BRLP1: PUSH P,FLP
PUSH P,FXP
PUSH P,SP
PUSHJ P,LISP1A
MOVEM A,V.
PUSHJ P,TLPRINT
HRRZ TT,-2(P)
HRRZ D,-1(P)
HRRZ R,(P)
SUB P,R70+3
PUSHJ P,PDLCHK ;CHECK PDL LEVELS
Q% JRST TERPRI ;WILL RETURN TO BRLP
IFN QIO,[
HRRZ A,VINFILE
SKIPE TAPRED
CAIN A,TRUTH
HRRZ A,V%TYI
MOVE TT,TTSAR(A)
TLNN TT,TTS<TY>
POPJ P,
MOVEI TT,FT.CNS
SKIPN AR1,@TTSAR(A)
POPJ P,
CAMN AR1,V%TYO
JRST BRLP5A
MOVEI TT,F.MODE
MOVE F,@TTSAR(A)
TLNE F,FBT<LN>
POPJ P,
JRST BRLP5A
] ;END OF IFN QIO
BRLP: PUSH P,BRLP
SKIPE A,BLF
JRST EVAL ;EVAL BREAKLEVEL FORM (RETURNS TO BRLP)
Q% PUSHJ P,IREAD
IFN QIO,[
HRRZ A,VINFILE
SKIPE TAPRED
CAIN A,TRUTH
HRRZ A,V%TYI
PUSH P,A
REPEAT 2, PUSH P,[BRLP5] ;ONCE FOR RANDOM EOF VALUE
MOVNI T,1
JRST IREAD1
BRLP5: POP P,B
CAIE A,BRLP5
JRST BRLP6
MOVE TT,TTSAR(B) ;SIMPLY TERPRI ON EOF
TLNN TT,TTS<TY> ; IF APPROPRIATE
POPJ P,
MOVEI TT,FT.CNS
SKIPN AR1,@TTSAR(B)
POPJ P,
BRLP5A: TLO AR1,-1
SKIPN TTYOFF
JRST TERP1
POPJ P,
BRLP6:
] ;END OF IFN QIO
PUSHJ P,SPCFLS
SKIPN VDOLLRP
JRST BRLP4
CAMN A,VDOLLRP
JRST BRLP7
BRLP4: HLRZ B,(A)
CAIE B,QRETURN
JRST BRLP1
JSP T,%CADR
BRLP3: PUSHJ P,EVAL
BRLP2: MOVEI B,QBREAK
JRST THROW1 ;ESCAPE FROM BRGEN LOOP
BRLP7: MOVEI A,NIL
JRST BRLP2
SPCFLS: SKIPE VOREAD
POPJ P,
PUSH P,A
PUSHJ P,ATOM
JUMPE A,POPAJ
MOVEI T,0 ;PEEL OFF A SPACE, IF THAT
PUSHJ P,TYIPEEK+1 ;WAS WHAT TERMINATED THE ATOM
MOVE T,VREADTABLE
MOVE TT,@TTSAR(T)
MOVEI T,0
TLNE TT,100000 ;WORTHLESS CHAR, OR SPACE ETC.
PUSHJ P,%TYI
JRST POPAJ
.SET: EXCH A,AR1
.SET1: PUSH P,A
PUSHJ P,BIND
POP P,A
EXCH A,AR1
JRST SETXIT
.STOLZ: PUSH P,B
PUSHJ P,NCONS
MOVEI B,QM
PUSHJ P,XCONS
MOVEI B,QSTORE
PUSHJ P,XCONS
JRST .STOL1
.STORE: SKIPN D,LISAR
JRST .STOLZ
HLL D,ASAR(D)
TLNE D,AS<FX+FL>
JRST .STOR2
.STOR0: MOVEI TT,(R)
JUMPL R,.STOR1
HRLM A,@TTSAR(D)
JRST (T)
.STOR1: HRRM A,@TTSAR(D)
JRST (T)
.STOR2: MOVEI F,(T)
TLNN D,AS<FX>
JSP T,FLNV1X
JSP T,FXNV1
.STOR3: EXCH TT,R
MOVEM R,@TTSAR(D)
JRST (F)
FWNACK: SETZ T, ;COUNT UP ACTUAL NUMBER OF ARGS
MOVEI D,(A) ;LEAVES RESULT IN T
FWNAC1: JUMPE D,LWNACK
HRRZ D,(D)
SOJA T,FWNAC1
LWNACK: MOVE D,(TT) ;GET WORD OF BITS
ASH D,(T)
TLNE D,2 ;SKIP UNLESS WNA
JRST 1(TT)
JRST WNAL0
;;; PUSH CRUFT FOR AN ERRSET/CATCH/READEOF FRAME
;;; BEWARE! THE COMPILER DEPENDS ON THE LENGTH OF THE
;;; ERRSET FRAME BEING A CONSTANT.
ERSTP: PUSH P,PA3 ;"ERRSET" PUSH
PUSH P,SP ;MUST SAVE TT - SEE $TYI
PUSH P,FLP
PUSH P,FXP
REPEAT LEP1, PUSH P,ERRTN+.RPCNT
LERSTP==.-ERSTP ;LENGTH OF ERRSET PUSH
JRST (T)
ERUN0: HRRZ TT,ERRTN ;GENERAL BREAK OUT OF AN ERRSET
SKIPE D,UIRTN
CAIL TT,(D)
JRST ERR1A
JSP TT,UIBRK ;MAYBE BREAK UP A USER INTERRUPT FIRST
JRST ERUN0
ERR1A: MOVE P,ERRTN
ERR1: SETZM PANICP
MOVSI D,-LEP1+1(P)
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
SUB P,EPC1
POP P,FXP
POP P,FLP
POP P,TT
POP P,PA3
JRST UBD0 ;RESTORE CONDITIONS AND PROCEED
EPC1: LEP1,,LEP1
UIBRK:
Q% HRRM TT,-2(D) ;BREAK OUT OF A USER INTERRUPT
Q$ HRRM TT,-1(D)
HRRO FXP,1(D) ;JUST SET LEFT HALF OF PDL POINTERS
HLRO FLP,1(D) ; TO -1 FOR BIBOP, AND LET PDLOV
Q% HRROI P,-LUINF-1(D) ; DO THE REST OF THE WORK!
Q$ HRROI P,-UIFRM(D)
IFE QIO,[ .SEE FRETURN
MOVEM F,-LSWS(FXP) ;LET F BE SECURE OVER THE RESTORATION
MOVEM T,-LSWS-4(FXP) ;T TOO
MOVEM C,-3(P) ;C TOO
MOVEM B,-4(P) ;B TOO
MOVEM A,LUINF(P) ;A TOO
] ;END OF IFE QIO
IFN QIO,[
MOVEM F,UISAVT-T+F(FXP) ;LET F BE SAFE OVER RESTORATION
MOVEM T,UISAVT(FXP) ;T TOO
MOVEM C,UISAVA-A+C(P) ;C TOO
MOVEM B,UISAVA-A+B(P) ;B TOO
MOVEM A,UISAVA(P) ;A TOO
] ;END OF IFN QIO
JRST UINT0X
CIN0: IN0 ;SURPRISE!
CONS1FX: TDZA B,B
CONSPFX: POP FXP,TT
CONSFX: JSP T,FXCONS
CONSIT: PUSHJ P,CONS
BAPOPJ: MOVEI B,(A)
POPJ P,
SUBTTL VARIOUS COMMON EXITS
ZPOPJ: TDZA TT,TT ;ZERO TT, THEN POPJ
POPNVJ: JSP T,FXNV1 ;FXNV1, THEN POPJ
CCPOPJ: POPJ P,CCPOPJ ;NOT CPOPJ! WILL SCREW BAKTRACE
0POPJ: SKIPA A,CIN0 ;PUT A LISP FIXNUM 0 IN A AND POPJ
POP2J: SUB P,R70+2 ;POP 2 PDL SLOTS AND POPJ
CPOPJ: POPJ P,CPOPJ ;SACRED TO BAKTRACE (Q.V.)
S1PAJ: SUB P,R70+1 ;POP 1 PDL SLOT, POP INTO A, AND POPJ
POPAJ: POP P,A ;POP A, THEN POPJ
CPOPAJ: POPJ P,POPAJ
POPJ1: AOSA (P) ;SKIPPING POPJ RETURN
POP1J: SUB P,R70+1 ;POP 1 PDL SLOT AND POPJ
CPOP1J: POPJ P,POP1J
M1TTPJ: SKIPA TT,XC-1 ;-1 IN TT, THEN POPJ
POPCJ: POP P,C ;POP C, THEN POPJ
CPOPCJ: POPJ P,POPCJ
UNLKFALSE: TDZA A,A
UNLKTRUE: MOVEI A,TRUTH
UNLKPOPJ
PX1J: SUB FXP,R70+1
POPJ P,
POPXDJ: POP FXP,D
POPJ P,
SUBTTL VARIOUS COMMON SAVE AND RESTORE ROUTINES
SAV5: PUSH P,A
SAV5M1: PUSH P,B
SAV5M2: PUSH P,C
SAV5M3: PUSH P,AR1
PUSH P,AR2A
CPOPXJ: POPJ FXP,
SAV3: PUSH P,A
PUSH P,B
PUSH P,C
POPJ FXP,
R5M1PJ: PUSH FXP,CCPOPJ
RST5M1: POP P,AR2A
POP P,AR1
POP P,C
POP P,B
CR5M1PJ: POPJ FXP,R5M1PJ
RST5M2: POP P,AR2A
POP P,AR1
POP P,C
POPJ FXP,
RST5M3: POP P,AR2A
POP P,AR1
POPJ FXP,
SAVX5: PUSH FXP,T
PUSHJ P,SAVX3
PUSH FXP,F
POPJ P,
SAVX3: PUSH FXP,TT
PUSH FXP,D
PUSH FXP,R
POPJ P,
RSTX5: POP FXP,F
POP FXP,R
POP FXP,D
PXTTTJ: POP FXP,TT
POPXTJ: POP FXP,T
POPJ P,
RSTX3: POP FXP,R
RSTX2: POP FXP,D
RSTX1: POP FXP,TT
CPOPNVJ: POPJ P,POPNVJ
SUBTTL VARIOUS KINDS OF FRAME MARKERS
$ERRFRAME=525252,,EPOPJ ;ERROR FRAME
$EVALFRAME=525252,,POP2J ;EVAL FRAME
;; $APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME DEFINED BELOW
$UIFRAME=525252,,CPOPAJ ;USER INTERRUPT FRAME
;;; FORMAT OF EVALFRAME:
;;; <FLP>,,<FXP>
;;; <SP>,,<FORM>
;;; $EVALFRAME
;;; FORMAT OF APPLYFRAME:
;;; -- ARGS --
;;; <FLP>,,<FXP>
;;; <SP>,,<FUNCTION>
;;; $APPLYFRAME
;;; WHERE -- ARGS -- MAY BE ONE OF THREE THINGS, DEPENDING
;;; ON ITS LEFT HALF:
;;; LH=0 RH=LIST OF ARGS
;;; LH<0 LH,,RH=AOBJN POINTER TO ARGS VECTOR (E.G. FOR LSUBR)
;;; LH>0 RH=LAST ARG; OTHER ARGS ARE BELOW THIS ON THE
;;; STACK. IN THIS CASE THE APPLYFRAME MAY BE MORE
;;; THAN FOUR WORDS LONG.
;;; EXAMPLE: MOVEI A,QFOO
;;; MOVEI B,QBAR
;;; CALL 2,QUUX
;;; CAUSES THIS APPLYFRAME TO APPEAR ON THE STACK:
;;; 0,,QFOO
;;; 2,,QBAR
;;; <FLP>,,<FXP>
;;; <SP>,,QUUX
;;; $APPLYFRAME
AFPOPJ: HLRE T,-2(P) ;APPLYFRAME POPJ
SKIPG T ;FIGURE OUT LENGTH OF
MOVEI T,1 ; APPLY FRAME
ADDI T,2
HRLI T,(T)
SUB P,T ;POP CRUFT FROM PDL
POPJ P, ;RETURN
$APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME
SUBTTL NUMERIC TYPE-TESTING, CONVERSION, AND VALUE ROUTINES
IFN BIGNUM,[
FLTSK1: %WTA NMV5 ;BIGNUM NOT ACCEPTABLE
JRST FLTSKP
] ;END OF IFN BIGNUM
FLTSK2: %WTA NMV3 ;NON-NUMERIC VALUE
FLTSKP: MOVEI TT,(A) ;"FLOAT SKIP" ROUTINE
LSH TT,-SEGLOG ; SKIPS 0 FOR FIXNUMS, 1 FOR FLONUMS
HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT
2DIF JRST @(TT),FLTSTB,QLIST .SEE STDISP
FLTSTB: FLTSK2 ;LIST ;ERROR
FLTSFX ;FIXNUM ;SKIPS 0
FLTSFL ;FLONUM ;SKIPS 1
BG$ FLTSK1 ;BIGNUM ;ERROR
FLTSK2 ;SYMBOL ;ERROR
REPEAT HNKLOG, FLTSK2 ;HUNKS ;ERROR
FLTSK2 ;RANDOM ;ERROR
FLTSK2 ;ARRAY ;ERROR
IFN .-FLTSTB-NTYPES, WARN [WRONG LENGTH TABLE]
IFN BIGNUM, NVSKBG:
FLTSFX: MOVE TT,(A)
JRST (T)
IFN BIGNUM, NVSKFX:
FLTSFL: MOVE TT,(A)
JRST 1(T)
IFN BIGNUM,[
NVSKP2: %WTA NMV3 ;NON-NUMERIC VALUE
NVSKIP: MOVEI TT,(A) ;"NUMERIC VALUE SKIP"
LSH TT,-SEGLOG ;SKIPS: 0 => BIGNUM, 1 => FIXNUM, 2 => FLONUM, ELSE ERROR
HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT
2DIF JRST @(TT),NVSKTB,QLIST .SEE STDISP
NVSKTB: NVSKP2 ;LIST ;ERROR
NVSKFX ;FIXNUM ;SKIPS 1
NVSKFL ;FLONUM ;SKIPS 2
BG$ NVSKBG ;BIGNUM ;SKIPS 0, LEAVES BIGNUM HEADER IN TT
NVSKP2 ;SYMBOL ;ERROR
REPEAT HNKLOG, NVSKP2 ;HUNKS ;ERROR
NVSKP2 ;RANDOM ;ERROR
NVSKP2 ;ARRAY ;ERROR
IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE]
NVSKFL: MOVE TT,(A)
JRST 2(T)
] ;END OF IFN BIGNUM
CFIX1: FIX1 ;FOR (% 0 0 FIX1)
CFLOAT1: FLOAT1 ;FOR (% 0 0 FLOAT1)
R70: REPEAT 20, .RPCNT,,.RPCNT ;COMMON LAP CONSTANTS ALSO USED BY LISP CODE
ZZZ==5
IFL ZZZ-NACS, ZZZ==NACS ;NEED AT LEAST <NACS> OF THESE
REPEAT ZZZ, .RPCNT-ZZZ
XC==. ;WRITE "XC-N" TO GET THE CONSTANT -N
FIX2: JSP T,IFIX
FIX1: JSP T,FIX1A
POPJ P,
IFIX: MULI TT,400
TSC TT,TT
ASH TT+1,-243(TT)
MOVE TT,TT+1
JRST (T)
FLOAT2: JSP T,IFLOAT
FLOAT1: JSP T,FPCONS
POPJ P,
IFLOAT: TLNE TT,777000
JRST IFLT1
IFLT5: FSC TT,233 ;FSC NORMALIZES RESULT
JRST (T)
IFLT1: TLC TT,777000
TLCN TT,777000
JRST IFLT5
IFLT2: MOVEM D,IFLT9 ;28. TO 35. BITS MAGNITUDE
JUMPL TT,IFLT3
HLRZ D,TT
MOVEI TT,(TT)
IFLT4: FSC D,255
FSC TT,233
FAD TT,D
MOVE D,IFLT9
JRST (T)
IFLT3: HLRO D,TT
HRROI TT,(TT)
AOJA D,IFLT4
DEFINE FXNV AC,FL
EFXNV!AC:
IFSN FL, , EXCH A,AC
%WTA FXNMER
IFSN FL, , EXCH A,AC
FXNV!AC: MOVEI TT-1+AC,(AC)
ROT TT-1+AC,-SEGLOG
SKIPL TT-1+AC,ST(TT-1+AC)
TLNN TT-1+AC,FX
JRST EFXNV!AC
MOVE TT-1+AC,(AC)
JRST (T)
TERMIN
IRPS A,B,[1 2-3-4-]
FXNV A,B
TERMIN
FLNV1X: AOJA T,FLNV1 ;FLNV1 WITH SKIP RETURN
EFLNV1: %WTA FLNMER
FLNV1: SKOTT A,FL
JRST EFLNV1
MOVE TT,(A)
JRST (T)
BAKPRO
RSXST: HRRZ TT,VREADTABLE ;READ CHARACTER SYNTAX
HRRZ TT,TTSAR(TT) ; TABLE SETUP
HRLI TT,((A)) ;USED AS INDIRECT ADDRESS WITH
MOVEM TT,RSXTB ;INDEX FIELD A
NOPRO
JRST (T)
SUBTTL SUPPORT FOR LAP/FASLAP CODE
REPEAT 20, CONC \20-.RPCNT,NPUSH,: PUSH P,R70
NPUSH: JRST (T) ;WRITE JSP T,NPUSH-N TO PUSH N NIL'S
REPEAT 10, CONC \10-.RPCNT,PUSH,: PUSH FXP,R70
0PUSH: JRST (T) ;WRITE JSP T,0PUSH-N TO PUSH N 0'S
REPEAT 10, CONC \10-.RPCNT,.PUSH,: PUSH FLP,R70
0.0PUSH: JRST (T) ;WRITE JSP T,0.0PUSH-N TO PUSH N 0.0'S
CINTREL: INTREL ;RANDOM USEFUL RETURN ADDRESS
INTREL: POP FXP,INHIBIT
CHECKI: SKIPN NOQUIT ;CHECKS FOR ELAYED INTRRUPTS
SKIPN INTFLG
POPJ P, ;EXIT IF NONE
JRST CKI0 ;ELSE GO PROCESS
JRST .LCAFL ;SETUP FOR FLONUM TYPE COMPILED LSUBRS
JRST .LCAFX ;SETUP FOR FIXNUM TYPE COMPILED LSUBRS
.LCALL: PUSH P,R70 ;SETUP FOR REGULAR COMPILED LSUBRS
.LCAF5: MOVN TT,T ;NUMBER OF ARGS
ADDI T,-1(P) ;ADDR OF BEGINNING OF ARG VECTOR
CAIL TT,XHINUM
JRST LXPRLZ
MOVEI A,IN0(TT)
MOVEI TT,(T) ;ARGLOC, IS RANDOM PDL PTR
JSP T,SPECBIND ;LOC. OF ARG. VECTOR STORED IN ARGLOC, WHICH
0 TT,ARGLOC ;IS TREATED LIKE SPECIAL CELL FOR ERRRET'S
0 A,ARGNUM
PUSHJ P,(D) ;PASSED TO USERS COMPILED FUN
POP P,D
SKIPN T,@ARGNUM
JRST .+3
HRLS T ;GOT TO GET RID OF THE ARGS
SUB P,T
JUMPE D,UNBIND ;THIS EXIT SIGNALS CALL TO NOTYPE LSUBR, OR NCALL TO NUMERIC
PUSH P,D
JRST UNBIND ;EXITS THRU EITHER FIX1 OR FLOAT1, MEANS REG CALL TO NUMERIC LSUBR
.LCAFX: PUSH P,CFIX1
AOJA D,.LCAF5
.LCAFL: PUSH P,CFLOAT1
AOJA D,.LCAF5
JRST CATPUS ;COMPILED CODE CALLS CATCH
ERSETUP: PUSH P,B ;COMPILED CODE CALLS ERRSET
JSP T,ERSTP
MOVEM P,ERRTN
SETZM ERRSW
SKIPE A
SETOM ERRSW
JRST (TT)
NORET: PUSHJ P,NOTNOT
HRRZM A,VNORET
POPJ P,
.RSET: PUSHJ P,NOTNOT
MOVEM A,V.RSET
POPJ P,
NOUUO: PUSHJ P,NOTNOT
HRRZM A,VNOUUO
POPJ P,
SUBTTL VARIOUS LISTING AND DE-LISTING ROUTINES
LIST: MOVEI R,CPOPJ
LIST1: MOVEI A,NIL ;BASICALLY, THE FUNCTION "LIST"
LIST1A: JUMPE T,(R)
POP P,B
PUSHJ P,XCONS
AOJA T,.-3
;;; INTERNAL LISTING FUNCTION; EVALUATES A LIST OF ARGS,
;;; STACKING THEIR VALUES ON THE PDL
KLIST: HLRZ B,(A) ;SUPER-HACKISH VERSION
PUSH P,B
HRRZ A,(A)
JLIST: HLRZ B,(A) ;HACKISH VERSION WHICH DOESN'T
PUSH P,B ; EVAL FIRST ARG OR COUNT IT
HRRZ A,(A)
ILIST: MOVEI T,0 ;CALLED BY JSP TT,ILIST
JUMPE A,(TT)
PUSH FXP,TT
PUSH FXP,T ;CONTAINS 0 - USED AS COUNTER
PUSH FXP,R ;MUST SAVE R!
ILIST1: PUSH P,A ;OTHERWISE, THIS EVAL LOOP
HLRZ A,(A) ; MAY CLOBBER ANYTHING
PUSHJ P,EVAL
ILIST3: EXCH A,(P) ;SAVE VALUE ON STACK
HRRZ A,(A)
SOS -1(FXP) ;COUNT VALUES
JUMPN A,ILIST1
POP FXP,R ;RESTORE R
POP FXP,T ;T HAS -<# OF VALUES ON PDL>
POPJ FXP,
IFN QIO,[
SUBTTL NEWIO GET READTABLE
GTRDTB: HRRZ AR2A,VREADTABLE
SKIPN V.RSET
JRST (T)
SKOTT AR2A,SA
JRST GTRDT8
MOVE TT,ASAR(AR2A)
TLNE TT,AS<RDT>
JRST (T)
GTRDT8: MOVEI AR2A,READTABLE
EXCH AR2A,VREADTABLE
EXCH AR2A,A
PUSHJ P,GTRDT9
MOVEI A,(AR2A)
JRST GTRDTB
] ;END OF IFN QIO,
SUBTTL NOINTERRUPT FUNCTION
NOINTERRUPT: JUMPE A,CHECKU ;SUBR 1 - ENABLE/DISABLE
CAIN A,QTTY
Q% JRST CHECKA
Q$ JRST CHECKU
SETO A, ; RANDOM ASYNCHRONOUS
NOINT0: EXCH A,UNREAL ; "REAL TIME" INTERRUPTS
SKIPGE A ; (CLOCKS AND TTY)
MOVEI A,TRUTH
POPJ P,
;;; CHECK FOR ANY DELAYED "REAL TIME" INTERRUPTS, AND RUN THEM
;;; IF ANY. MUST DO THEM IN THE ORDER ↑G/↑X, CLOCKS, AND OTHER.
;;; NOTE THAT AFTER A ↑G OR ↑X, CHECKU GETS CALLED AGAIN.
CHECKU: SKIPN UNREAL ;NONE CAN BE PENDING IF NOT DELAYING
Q% POPJ P,
Q$ JRST NOINT0
CHECKQ:
Q$ PUSH P,A
PUSHJ P,UINTPU
NOINT1: SKIPN (P)
JRST NOINT5
SKIPE F,UNRC.G ;PROCESS ↑G/↑X FIRST
JRST CKI2A ;TOP LEVEL OR ERRRTN WILL DO A CHECKU
NOINT5: PUSHJ P,NOINTA ;NOW PROCESS ALARMCLOCK INTERRUPTS
JRST NOINT1
NOINT3: SKIPG F,UNREAR ;NOW ANY OTHER INTERRUPTS
JRST NOINT4
SOS UNREAR
Q% MOVE A,UNREAR(F)
Q$ MOVE D,UNREAR(F)
Q$ TRNE D,400000 ;IF (NOINTERRUPT 'TTY), SUPPRESS
Q$ SKIPN (P) ; TTY INTERRUPTS AT THIS TIME
PUSHJ P,YESINT ;FOR QIO, MAY CLOBBER R (SEE UISTAK)
JRST NOINT1
NOINT4: SKIPG A,UNREAL
MOVEI A,TRUTH
Q% SETZM UNREAL
Q$ POP P,UNREAL
JRST UINTEX
IFE QIO,[
CHECKA: SKIPL UNREAL
JRST NOINT0
CHECKZ: PUSHJ P,UINTPU
PUSHJ P,NOINTA
JRST .-1
MOVEI A,QTTY
MOVEM A,UNREAL
MOVEI A,TRUTH
JRST UINTEX
] ;END OF IFE QIO
;;; DO NOT TRANSFORM THE "PUSHJ, POPJ" SEQUENCES INTO "JRST".
;;; YESINT DEPENDS ON LOOKING AT THE PUSHJ ADDRESS TO SEE WHETHER
;;; WE CAME FROM NOINTERRUPT OR ELSEWHERE!
NOINTA:
Q% SKIPN A,UNRRUN ;PROCESS RUNTIME ALARMCLOCK FIRST
Q$ SKIPN D,UNRRUN
JRST NOINT2
SETZM UNRRUN
PUSHJ P,YESINT
POPJ P,
NOINT2:
Q% SKIPN A,UNRTIM ;NOW THE REAL TIME ALARMCLOCK
Q$ SKIPN D,UNRTIM
JRST POPJ1
SETZM UNRTIM
PUSHJ P,YESINT
POPJ P,
ENOINT==. .SEE UINT0N
SUBTTL CAR/CDR ROUTINES AND FUNCTIONS
;;; HERE BELOW FOLLOW THE "FAST" CAR-CDR ROUTINES,
;;; USED WHEN *RSET=NIL, AND BY COMPILED CODE.
;;; NOTE THAT THE RELATIVE DISPLACEMENT OF THE FUNCTION ENTRY POINTS
;;; IS VERRRRRY IMPORTANT TO THE POOOR COMPLR.
;;; DONT EVER CHANGE THEM!!
CARCDR: ;INDEX NUMBER FOR CALL BY COMPILED CODE
%CADDDR: SKIPA A,(A) ; 0
%CADDAR: HLRZ A,(A) ; 1
%CADDR: SKIPA A,(A) ; 2
%CADAR: HLRZ A,(A) ; 3
%CADR: SKIPA A,(A) ; 4
%CAAR: HLRZ A,(A) ; 5
%CAR: HLRZ A,(A) ; 6
JRST (T)
%CDDDDR: SKIPA A,(A) ; 8
%CDDDAR: HLRZ A,(A) ; 9
%CDDDR: SKIPA A,(A) ;10.
%CDDAR: HLRZ A,(A) ;11.
%CDDR: SKIPA A,(A) ;12.
%CDAR: HLRZ A,(A) ;13.
%CDR: HRRZ A,(A) ;14.
JRST (T)
%CAADDR: SKIPA A,(A) ;16.
%CAADAR: HLRZ A,(A) ;17.
%CAADR: SKIPA A,(A) ;18.
%CAAAR: HLRZ A,(A) ;19.
JRST %CAAR
%CDADDR: SKIPA A,(A) ;21.
%CDADAR: HLRZ A,(A) ;22.
%CDADR: SKIPA A,(A) ;23.
%CDAAR: HLRZ A,(A) ;24.
JRST %CDAR
%CAAADR: SKIPA A,(A) ;26.
%CAAAAR: HLRZ A,(A) ;27.
JRST %CAAAR
%CDDADR: SKIPA A,(A) ;29.
%CDDAAR: HLRZ A,(A) ;30.
JRST %CDDAR
%CDAADR: SKIPA A,(A) ;32.
%CDAAAR: HLRZ A,(A) ;33.
JRST %CDAAR
%CADADR: SKIPA A,(A) ;35.
%CADAAR: HLRZ A,(A) ;36.
JRST %CADAR
;;; THE FOLLOWING TABLE IS A TRANSFER VECTOR: GIVEN THE INFO-NUMBER
;;; OF A CAR-CDR OPERATION, SAY N, THEN CARCDR[N-2] IS THE
;;; ADDRESS OF THE FAST ROUTINE FOR THAT OPERATION. NOTE THAT THE
;;; INFO-NUMBER IS NOT THE SAME AS THE INDEX-NUMBER-FOR-COMPILED-CODE
%CARCDR:
IRP X,,[A,D,AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]
%C!X!R
TERMIN
;;; STANDARD INTERPRETER SUBRS FOR THE VARIOUS CAR-CDR
;;; OPERATIONS. THESE CALL A CENTRAL DECODER WHICH IN *RSET
;;; MODE PERFORMS TYPE CHECKING ON THE OPERAND AT EACH STEP.
CRSUBRS:
IRP X,,[A,D,AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]
C!X!R: JSP F,CR0
TERMIN
;;; LET A=0, D=1, AND LET CWXYZR BE A CAR-CDR OPERATION, WITH
;;; THE VARIABLES W,X,Y,Z RANGING OVER {,A,D}. LET A NUMBER N
;;; BE COMPUTED CORRESPONDING TO CXYZWR AS FOLLOWS:
;;; N = Z + 2 IF W,X,Y ARE NULL
;;; N = Y*2 + Z + 4 IF W,X ARE NULL
;;; N = X*4 + Y*2 + Z + 10 IF W IS NULL
;;; N = W*10 + X*4 + Y*2 + Z + 20 IF NONE OF W,X,Y,Z ARE NULL
;;; NOTE TWO THINGS:
;;; [1] THIS REPRESENTATION OF A CAR-CDR OPERATION IS EASILY
;;; BITWISE DECODABLE. THE POSITION OF THE FIRST 1 BIT
;;; INDICATES THE START OF THE REST OF THE ENCODING, WHICH HAS
;;; 0 FOR CAR, 1 FOR CDR AT EACH POSITION.
;;; [2] FOR ANY SET OF OPERATIONS COMPLETE FROM CAR AND CDR,
;;; THROUGH CAAR, CADR, ... TO "LEVEL M" CAR-CDR'S (THOSE WITH
;;; M A'S AND D'S), THIS ENCODING PRODUCES A COMPACT ENCODING,
;;; M+1
;;; WITH N RANGING FROM 2 TO 2 -1 INCLUSIVE.
;;;
;;; NAME N (OCTAL) N (BINARY)
;;; CAR 2 10
;;; CDR 3 11
;;; CAAR 4 100
;;; CADR 5 101
;;; . . .
;;; CDDADR 35 11101
;;; CDDDAR 36 11110
;;; CDDDDR 37 11111
CR0: SKIPE V.RSET
JRST CR1
POP P,T
JRST @%CARCDR-<CRSUBRS+1>(F) ;QUICK VERSION OF *RSET = NIL
CR1: PUSHJ P,SAVX3 ;##### LOSS! GO AWAY WHEN COMPILER IS SMARTER.
CR1A: MOVEI D,(A)
IFN D10,[
MOVEI T,400002(F) ;400000 IS FOR CA.DER
SUBI T,<CRSUBRS+1>
] ;END OF IFN D10
.ELSE MOVEI T,400002-<CRSUBRS+1>(F) ;T GETS ENCODING "N"
CR2:
SKOTT D,LS ;CHECK FOR LIST TYPE
JRST CR4
CR3: TRNE T,1 ;SKIP IF CAR OPERATION
SKIPA D,(D)
HLRZ D,(D)
ROT T,-1
TRNE T,776 ;SKIP IF ALL DONE
JRST CR2
CR7: MOVEI A,(D)
JRST RSTX3 ;##### LOSS! GO AWAY WHEN COMPILER IS SMARTER
CR4: TRNE T,1 ;IF NEXT ARG ISN'T A LIST
SKIPA R,VCDR ;THEN CHECK OUT AGAINST PERMISSIBLITIES
MOVE R,VCAR
JUMPN R,CR5
TRNN D,-1 ;IF ONLY NIL AND LISTS PERMISSIBLE
JRST CR7 ;THEN LET NIL BECOME NIL (CAR NIL) = (CDR NIL) = NIL
JRST CA.DER ;ELSE, BOMB OUT
CR5: CAIE R,QSYMBOL
JRST CR6
TRNE D,-1
TLNE TT,SY
JRST CR3
JRST CA.DER ;LOSE IF NEITHER NIL NOR SYMBOL
CR6: CAIN R,QLIST
JRST CA.DER ;LIST TEST ON ARG HAS ALREADY FAILED, SO FAIL
JRST CR3 ;IF CAR,CDR NOT "LIST", "SYMBOL", OR "NIL", THEN OK FOR ANYTHING
SUBTTL VARIOUS LIST, SYMBOL, AND NUMBER CONSERS
PNGNK: ADDI C,PNBUF-1 ;USED ONLY BY INTERN - PURIFIES PNAME FOR BIBOP
SKIPGE LPNF
PUSHJ P,PNCONS
SKIPE V.PURE
PUSHJ P,PURCOPY
JRST SYCONS
PNGNK1: SKIPGE LPNF
PNGNK2: PUSHJ P,PNCONS
SYCONS:
BAKPRO
SKIPN FFY
JRST SYCON1
SKIPE V.PURE
JRST SYCON4
SKIPN B,FFY2
JRST SYCON1
MOVEM A,1(B)
MOVE A,[777000,,SUNBOUND]
XCTPRO
EXCH A,(B)
MOVEM A,FFY2
SYCON2: MOVSI A,(B)
EXCH A,@FFY
EXCH A,FFY
NOPRO
POPJ P,
SPECPRO INTSYX
SYCON1: PUSHJ P,AGC
JRST SYCONS
SYCON4: AOSL B,NPFFY2
SPECPRO INTSYQ
PUSHJ P,GTNPSG
ADD B,EPFFY2
AOS NPFFY2
SPECPRO INTSYP
MOVEM A,1(B)
MOVE A,[777200,,SUNBOUND]
MOVEM A,(B)
JRST SYCON2
NOPRO
;AHCONS SKIPS IN FROM ABOVE
NCONS: TRZA B,-1 ;SUBR 1 - (NCONS X) = (CONS X NIL)
XCONS: EXCH B,A ;SUBR 2 - (XCONS X Y) = (CONS Y X)
CONS: HRL B,A ;SUBR 2 - CONSTRUCT A DOTTED PAIR
SPECPRO INTC2X
CONS1: SKIPN A,FFS ;USES A,B
JRST CONS3
EXCH B,(A)
XCTPRO
CONS2: EXCH B,FFS
NOPRO
POPJ P,
SPECPRO INTC2X
CONS3: HLR A,B
PUSHJ P,AGC
NOPRO
JRST CONS1
PNCONS: PUSH FXP,T
MOVEI A,NIL
10$ SUBI C,PNBUF ;D10 CANT HAVE NEGATIVE RELOCATION
10$ MOVEI C,1(C) ;MUST CLEAR LEFT HALF OF C ALSO!
.ELSE MOVEI C,1-PNBUF(C) ;MOVEI IS FASTER THAN SUBI
PNG2: MOVE B,A
MOVE TT,PNBUF-1(C)
JSP T,FWCONS
PUSHJ P,CONS
SOJG C,PNG2
CPXTJ: JRST POPXTJ
FXCONS: ;FIXNUM CONS - MAY UNIQUIZE
FIX1A: CAIGE TT,XHINUM
CAMGE TT,[-XLONUM]
JRST FWCONS
MOVEI A,IN0(TT)
JRST (T)
SPECPRO INTZAX
FWCONS: SKIPN A,FFX ;FULL WORD CONS - ALWAYS CONSES
JSP A,AGC4
EXCH TT,(A)
XCTPRO
CONS4: EXCH TT,FFX
NOPRO
JRST (T)
FLCONX: AOJA T,FLCONS ;FLCONS WITH SKIP RETURN
SPECPRO INTZAX
FLCONS: ;FLONUM CONS
FPCONS: SKIPN A,FFL
JSP A,AGC4
EXCH TT,(A)
XCTPRO
CONS6: EXCH TT,FFL
NOPRO
JRST (T)
SUBTTL HUNK PRIMITIVES - CXR, RPLACX, HUNK<N>, HUNK, HUNKIFY
IFE HNKLOG,[
%CXR:
%RPX: LERR [SIXBIT \NO HUNKS IN THIS LISP - CXR/RPLACX!\]
] ;END OF IFE HNKLOG
IFN HNKLOG,[
CXR: JSP T,FXNV1 ;SUBR 2
SKIPE V.RSET
JSP F,CXR3 ;CHECK ARGS
ROT TT,-1
ADDI TT,(B)
JUMPGE TT,CXR2
HLRZ A,(TT)
POPJ P,
CXR2: HRRZ A,(TT)
POPJ P,
%CXR: ROT TT,-1 ;QUICK ENTRY FOR COMPILED CALLS
ADDI TT,(A)
JUMPGE TT,%CXR2
HLRZ A,(TT)
JRST (T)
%CXR2: HRRZ A,(TT)
JRST (T)
CXR30: TLNN T,$FS+VC
JRST CXR31
CAIG TT,1
JRST (F)
CXR31: EXCH A,B
WTA [INVALID OR WRONG LENGTH HUNK!]
EXCH A,B
CXR3: MOVEI T,(B)
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,HNK ;SECOND ARG MUST BE HUNK
JRST CXR30
MOVEI D,4
2DIF [LSH D,(T)]0,QHUNK1
CAMLE D,TT ;FIRST ARG MUST BE SMALLER THAN
JUMPGE TT,CXR34 ; LENGTH OF SECOND, YET NON-NEGATIVE
CXR33: WTA [BAD HUNK INDEX!]
JRST -3(F)
CXR34: MOVE D,TT
ROT D,-1
ADDI D,(B)
HRRZ T,(D)
SKIPGE D
HLRZ T,(D)
CAIN T,-1
JRST CXR33
JRST (F)
;;; IFN HNKLOG
RPLACX: JSP T,FXNV1 ;SUBR 3
SKIPE V.RSET
JSP F,CXR3 ;CHECK ARGS
ROT TT,-1
ADDI TT,(B)
JUMPGE TT,RPLX2
HRLM C,(TT)
JRST BRETJ ;RETURN SECOND ARG
RPLX2: HRRM C,(TT)
JRST BRETJ
%RPX: ROT TT,-1 ;FOR COMPILED CODE
ADDI TT,(A)
JUMPGE TT,%RPX2
HRLM B,(TT)
JRST (T)
%RPX2: HRRM B,(TT)
JRST (T)
HNKSZ0: WTA [NOT A HUNK - HUNKSIZE!]
JRST HNKSZ1
HUNKSIZE: ;SUBR 1 - NCALLABLE
PUSH P,CFIX1
HNKSZ1: MOVEI T,(A)
LSH T,-SEGLOG
SKIPL T,ST(T)
JRST HNKSZ0
MOVEI TT,2 ;RANDOM CONSES ARE OF SIZE 2
TLNN T,HNK
POPJ P,
MOVEI D,1
2DIF [LSHC TT,(T)]0,QHUNK1-1
ADDI D,-1(A)
HNKSZ3: SETCM R,(D) ;OTHERWISE CALCULATE LENGTH
TLNE R,-1
POPJ P,
TRNE R,-1
SOJA TT,CPOPJ
SUBI D,1
SUBI TT,2
JUMPG TT,HNKSZ3
.VALUE
HUNKP: LSH A,-SEGLOG ;SUBR 1
SKIPGE A,ST(A)
TLNN A,HNK
JRST FALSE
JRST TRUE
REPEAT HNKLOG,[
SPECPRO INTZAX
CONC HUNK,\.RPCNT+1,: ;VARIOUS HUNK CONSERS
HRRZS FFH+.RPCNT ;FLUSH SIGN BIT - NEED A HUNK NOW
SKIPN A,FFH+.RPCNT
JSP A,AGC4
MOVE TT,(A)
XCTPRO
MOVEM TT,FFH+.RPCNT
REPEAT 2←.RPCNT, SETOM .RPCNT(A) ;MUST FILL OUT COMPONENTS
NOPRO ; WITH THE "UNUSED" POINTER
POPJ P,
] ;END OF REPEAT HNKLOG
;;; IFN HNKLOG
XHUNK0: WTA [BAD ARGUMENT TO MAKHUNK!]
MAKHUNK: SKOTT A,FX ;SUBR 1
JRST XHUNK5
SKIPGE TT,(A)
JRST XHUNK0
CAILE TT,2←HNKLOG ;CREATE HUNK WITH N COMPONENTS
JRST XHUNK0 ; INITIALIZED TO NIL
SOJL TT,FALSE
MOVEI T,1(TT)
PUSHJ P,XHUNK1
LSHC T,-1
JUMPE T,XHUNK6 ;BEWARE IF 1 OR 0 ELEMENTS
HRLOI T,-1(T) ;SEE HAKMEM FOR THIS EQVI HAK
EQVI T,(A)
SETZM (T)
AOBJN T,.-1
XHUNK6: SKIPGE TT
HLLZS (T)
POPJ P,
XHUNK1: JFFO TT,XHUNK2 ;SELECT CONSER FOR CORRECT SIZE HUNK
JRA A,ACONS
XHUNK2: JRST .+1-43+HNKLOG(D)
IRP X,,[1024,512,256,128,64,32,16,8,4]Y,,[9,8,7,6,5,4,3,2,1]
IFG Y-HNKLOG, .STOP
JRST HUNK!Y ;2↑<Y+1> THINGS
TERMIN
JRA A,ACONS ;2 THINGS - USE CONS
XHUNK5: JUMPGE TT,XHUNK0 .SEE LS
JSP TT,AP2 ;STACK LIST ON PDL, -COUNT IN T
HUNK: AOJG T,FALSE ;LSUBR
JUMPE T,POPNCONS
MOVNS TT,T ;CREATE HUNK BIG ENOUGH TO
MOVEI D,QHUNK ; HOLD ALL GIVEN ARGUMENTS,
CAIL TT,2←HNKLOG ; AND INSTALL THEM
JRST XHUNK7
JSP AR2A,HUNKF0
POPJ P,
XHUNK7: MOVNS T
SOJA T,WNALOSE
POPNCONS: POP P,A
JRST ACONS
HUNKF0: PUSHJ P,XHUNK1 ;CREATE A FRESH HUNK
POP P,B ;ALSO USED BY FASLOAD
HRRM B,(A) ;LAST ONE GOES IN ELEMENT 0
LSHC T,-1
MOVEI D,(A) .SEE LDLHNK
ADDI D,(T)
JUMPGE TT,HUNKF3
HUNKF2: POP P,B ;LOOP TO INSTALL ARGS IN HUNK
HRLM B,(D)
HUNKF3: SOJL T,(AR2A)
POP P,B
HRRM B,(D)
SOJA D,HUNKF2
] ;END OF IFN HNKLOG
SUBTTL ATOM, PLIST, SETPLIST, ASSOC AND FRIENDS
ATOM: LSH A,-SEGLOG ;CAN DO LSH HERE BECAUSE DON'T NEED ARG
SKIPGE ST(A) ;FALSE ONLY FOR NON-ATOMIC
TDZA A,A ; FREE-STORAGE POINTERS
MOVEI A,TRUTH
POPJ P,
LATOM: ;SKIP IF EQ TEST IS SUFFICIENT FOR EQUALITY
SPATOM: JUMPE A,1(T) ;SKIP IF NIL (WHICH IS SYMBOL)
SPAT1: SKOTT A,SY ;LEAVES TYPE BITS IN TT
JRST (T)
JRST 1(T)
PRPLSE: JUMPE A,PRPNIL
%WTA NASER
PLIST: JSP T,SPAT1 ;SUBR 1 - FETCH PROPERTY LIST
JRST PRPLSE
HRRZ A,(A)
POPJ P,
PRPNIL: HRRZ A,NILPROPS
POPJ P,
RPLIZ: JUMPE A,RPSNIL
%WTA NASER
SETPLIST: JSP T,SPAT1 ;SUBR 2 - SET PROPERTY LIST
JRST RPLIZ
HRRM B,(A)
POPJ P,
RPSNIL: HRRM B,NILPROPS
POPJ P,
SASSQ: SKIPA AR1,ASSQ
SASSOC: MOVEI AR1,SAS2
PUSH P,C
PUSHJ P,(AR1)
CALLF 0,@(P)
JRST POP1J
SAS2: MOVE AR1,B ;CHECK TO SEE WHETHER ASSOC CAN BE CONVERTED
JSP T,LATOM ;INTO AN ASSQ
JRST SAS3A
SAS0: SKIPE V.RSET
JSP T,SAS4
SAS1: JUMPE B,CPOPJ ;ASSOC USING AN EQ TEST, I.E. ASSQ
MOVS T,(B) ;MUST PRESERVE AR2A - SEE FASLAP
HLRZ TT,(T)
CAIN A,(TT)
JRST SAS1A
SAS1C: HLRZ B,T
JRST SAS1
SAS1A: HRRZ A,T
JUMPE A,SAS1C
SAS1B: POP P,T
JRST 1(T)
SAS3A: SKIPE V.RSET
JSP T,SAS4
SKIPA C,A
SAS3: HRRZ AR1,(AR1) ;THE FULL ASSOC THING USING EQUAL
JUMPE AR1,CPOPJ ;SAVE R - SEE SSGCPRO
MOVE A,C
HLRZ B,(AR1)
JUMPE B,SAS3
HLRZ B,(B)
PUSHJ P,EQUAL
JUMPE A,SAS3
HLRZ A,(AR1)
JRST SAS1B
ASSOC: SKIPA T,SASSOC
ASSQ: MOVEI T,SAS0 ;** NOTE - MUST NOT USE OTHER THAN A, B, TT
PUSHJ P,(T) ;** BECAUSE OF ASSQ'S FOR READ CHAR MACROS
FALSE: MOVEI A,0
POPJ P,
SAS4: JUMPE B,(T)
SKOTT B,LS
JRST SASERR
HLRZ TT,(B)
JUMPE TT,(T)
SKOTT TT,LS+SY
JRST SASERR
JRST (T)
SUBTTL GET, GETL, PUTPROP, REMPROP FUNCTIONS
GET: SKOTT A,LS+SY
JRST GET3
CAIN B,QVALUE ;CROCK CROCK CROCK!!!!!
TLNN TT,SY
JRST GET1
JUMPE A,BOUND1
HLRZ B,(A) ;MORE CROCK MORE CROCK MORE CROCK!!!!!!
HRRZ A,(B) ; (BUT LAP DEPENDS ON IT...)
CAIN A,SUNBOUND
SETZ A,
POPJ P,
BOUND1: MOVEI A,VNIL
POPJ P,
GET3: JUMPN A,FALSE
MOVEI A,NILPROPS
CAIE B,QVALUE
JRST GET1
MOVEI A,VNIL
POPJ P,
GET0: HRRZ A,(TT) ;USES ONLY A,B,TT
JUMPE A,CPOPJ
GET1: HRRZ TT,(A) ;MUST PRESERVE C, AR1, T, D
JUMPE TT,FALSE ;(SEE EVAL AT EV3, MKNAM3, .REARRAY, AND ARRY1)
HLRZ A,(TT) ;ALSO PRESERVE R, SEE UUOH1
CAIE A,(B) ;ALSO AR2A AND F, SEE FASLOAD
JRST GET0
HRRZ TT,(TT)
HLRZ A,(TT)
POPJ P,
SARGET: MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,SA
POPJ P,
ARGET: JSP T,SPATOM ;GET ARRAY PROPERTY FROM ATOM
JSP T,PNGE1
ARGET1: MOVEI B,QARRAY
JRST GET1
PNGET: JSP T,SPATOM ;INTERNAL SUBROUTINE -GET PNAME PROP FROM ATOM
PNGT1: JSP T,PNGE
PNGT0: SKIPN A ;SAVES B
SKIPA TT,[$$$NIL]
HLRZ TT,(A) ;MUST DO IT INTO TT SO AS TO HAVE
HRRZ A,1(TT) ; CONTINUOUS GC PROTECTION
POPJ P,
.SEE CRSR40
GETLE2: %WTA NASER
GETL: SKIPN V.RSET
JRST GETL1
SKOTT B,LS
JUMPN B,GETLE
GETLA: SKOTT A,LS+SY
JRST GETL6
JRST GETL1
GETL6: JUMPN A,GETLE2
MOVEI A,NILPROPS
JRST GETL1
GETL0: HRRZ A,(A) ;USES A,B,C,T,TT
JUMPE A,CPOPJ
GETL1: HRRZ A,(A)
JUMPE A,CPOPJ
HLRZ T,(A)
SKIPA C,B
GETL4: HRRZ C,(C)
GETL3: JUMPE C,GETL0
HLRZ TT,(C)
CAIE T,(TT)
JRST GETL4
POPJ P,
PUTPROP: SKOTT A,LS+SY ;ATOM,VALUE,INDICATOR
JRST CSET7 ;OKAY TO PUTPROP ONTO NIL
CSET0C: MOVEI T,(A)
CSET0: HRRZ T,(T) ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
JUMPE T,CSET2
HLRZ TT,(T)
HRRZ T,(T)
CAIE TT,(C)
JRST CSET0
CSET0A:
PURTRAP CSET4,T, HRLM B,(T)
BRETJ:
SPROG2: MOVEI A,(B)
POPJ P,
CSET7: JUMPN A,PROPER
MOVEI A,NILPROPS
JRST CSET0C
CSET2: PUSH P,A ;ATOM DOESN'T HAVE SUCH A PROPERTY, SO
SKIPE V.PURE
JRST CSETP1
CSET2A: HRRZ A,(A)
PUSHJ P,XCONS ;CONS A FRESH ONE UP
HRRZ B,C
PUSHJ P,XCONS
POP P,C
HRRM A,(C)
$CADR: HRRZ A,(A)
HLRZ A,(A)
POPJ P,
CSET4: PUSH P,A ;FOOL PROPERTY IS IN A PURE PAGE
PUSH P,B
MOVEI T,(A)
CSET4A: HRRZ TT,(T) ;COPY ENOUGH OF THE PROPERTY LIST TO
PUSHJ P,CSET4C ; PERMIT THE PUTPROP
HLRZ A,(TT)
CAIE A,(C)
JRST CSET4A
POP P,B
POP P,A
JRST CSET0A
REMPROP: ;SUBR 2 - REMOVE PROPERTY FROM ATOMIC SYMBOL
SKOTT A,$FS+VC+SY
JRST REMP7 ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
REMP0: SKIPA D,A ;SAVE C, AR2A - SEE DEFPROP AND DEFUN
REMP1: HRRZ D,(T)
HRRZ T,(D)
JUMPE T,FALSE
MOVS TT,(T)
CAIE B,(TT)
JRST REMP1
HLRZ T,TT
REMP20: HRRZ TT,(T) ;A IS GC-PROTECTING THE ATOM
PURTRAP REMP3,D, HRRM TT,(D)
MOVEI A,(T)
POPJ P,
REMP7: JUMPN A,RMPER0
MOVEI A,NILPROPS
JRST REMP0
CSET4C: PUSHJ P,.+1 ;HAIRY WAY TO DO A DOUBLE COPY!
HRRZ A,(T)
MOVE B,(A)
PUSHJ P,CONS1
HRRM A,(T)
MOVEI T,(A)
POPJ P,
REMP3: PUSH P,A ;COME HERE ON PURE PAGE TRAP
PUSH P,B ;A ON PDL GC PROTECTS ATOM
MOVEI T,(A)
REMP3A: PUSHJ P,CSET4C ;COPY ENOUGH OF PROPERTY LIST
HRRZ TT,(T) ; TO DO REMPROP
HLRZ A,(TT)
CAME A,(P)
JRST REMP3A
HRRZ A,(TT)
HRRZ TT,(A)
HRRM TT,(T)
JRST POP2J
SUBTTL NOT, NULL, LAST, TIME, RUNTIME, BOUNDP
NOTNOT: JUMPE A,CPOPJ
JRST TRUE
NOT:
$NULL: JUMPN A,FALSE
TRUE: MOVEI A,TRUTH
CNOT: POPJ P,NOT
LAST: SKIPN T,A ;SUBR 1 - GET LAST CONS OF A LIST
POPJ P, ;RETURN NIL IF NIL
LAST1: HRRZ TT,(T) ;ELSE USE SUPER-FAST LOOP
JUMPE TT,LAST2 ; - ONLY TWO INSTRUCTIONS
HRRZ T,(TT) ; PER LIST ELEMENT SKIPPED!
JUMPN T,LAST1
SKIPA A,TT
LAST2: MOVEI A,(T)
POPJ P,
$RUNTIME: PUSH P,CFIX1
10% .SUSET [.RRUNT,,TT] ;RUNTIME IN 4. MICROSEC UNITS
10$ SETZ TT,
10$ RUNTIM TT, ;RUNTIME IN MILLISECS
10X WARN [TENEX RUNTIME?]
RNTM1:
10% LSH TT,2
10$ IMULI TT,1000.
POPJ P, ;ANSWER IN MICROSECONDS
TIME: PUSH P,CFLOAT1
IFN ITS,[
.RDTIME TT,
CAMGE TT,[72576000.] ;FOUR WEEKS OF 1/30 SEC TICS
JRST .+3
SUB TT,[72576000.]
JRST .-3
JSP T,IFLOAT
FDVR TT,[30.0]
] ;END OF IFN ITS
IFN D10,[
MSTIME TT,
IMULI TT,1000.
JSP T,IFLOAT
] ;END OF IFN D10
POPJ P,
BOUNDP: JUMPE A,TRUE
JSP T,SPATOM
JSP T,PNGE1
HLRZ T,(A) ;GET VALUE CELL
HRRZ A,(T) ;DO IT INTO T TO PROTECT FROM GC
HRRZ T,(A)
CAIN T,QUNBOUND ;RETURN VALUE CELL UNLESS UNBOUND
TDZA A,A
MOVEI A,TRUTH
POPJ P,
SUBTTL EQUAL FUNCTION
EQUAL: CAIN A,(B) ;EQ THINGS ARE EQUAL
JRST TRUE
MOVEM P,EQLP
PUSHJ P,EQUAL1 ;EQUAL1 ACTUALLY RETURNS ONLY IF EQUAL
JRST TRUE
EQUAL0: CAIN A,(B) ;EQ THINGS ARE EQUAL
POPJ P,
EQUAL1: MOVEI T,(A)
MOVEI TT,(B)
ROTC T,-SEGLOG ;GET TYPES OF ARGS
HRRZ T,ST(T)
HRRZ TT,ST(TT)
CAIE T,(TT) ;MUST HAVE SAME TYPE TO BE EQUAL
JRST EQLOSE
2DIF JRST @(T),EQLTBL,QLIST .SEE STDISP
EQLTBL: EQLLST
EQLNUM
EQLNUM
BG$ EQLBIG
EQLOSE ;PNAME ATOMS MUST BE EQ TO BE EQUAL
REPEAT HNKLOG, EQLHNK ;HUNKS REQUIRE RECURSION LIKE LISTS
EQLOSE ;RANDOMS AND NIL MUST BE EQ TO BE EQUAL
EQLOSE ;ARRAY POINTERS MUST BE EQ TO BE EQUAL
IFN .-EQLTBL-NTYPES, WARN [WRONG LENGTH TABLE]
EQLLST: PUSH P,(A)
PUSH P,(B)
HLRZ A,(A)
HLRZ B,(B)
PUSHJ P,EQUAL0 ;COMPARE CARS
HRRZ A,-1(P)
HRRZ B,0(P)
SUB P,R70+2
JRST EQUAL0 ;COMPARE CDRS
EQLNUM: MOVE T,(A)
CAMN T,(B) ;COMPARE VALUES OF NUMBERS
POPJ P,
EQLOSE: MOVE P,EQLP ;THE ULTIMATE FALSITY - ESCAPE BACK
JRST FALSE ; TO TOP LEVEL OF ENTRY TO EQUAL WITH FALSE
IFN BIGNUM,[
EQLBIG: HLRZ T,(A)
HLRZ TT,(B)
CAIE T,(TT) ;EQUAL BIGNUMS HAVE EQ SIGNS
JRST EQLOSE ; AND CDRS ARE EQUAL LISTS OF FIXNUMS
HRRZ A,(A) ;CHECK ONLY EQUAL CDRS
HRRZ B,(B)
JRST EQUAL0
] ;END OF IFN BIGNUM
IFN HNKLOG,[
EQLHNK: PUSH P,A
PUSH P,B
MOVNI T,2
2DIF [LSH T,(TT)]0,QHUNK1
HRLI B,(T)
PUSH P,A
PUSH P,B
EQLHN1: HLRZ A,@-1(P)
HRRZ B,(P)
HLRZ B,(B)
PUSHJ P,EQUAL0
HRRZ A,@-1(P)
HRRZ B,(P)
HRRZ B,(B)
PUSHJ P,EQUAL0
MOVE T,(P)
AOBJP T,EQLHN2
MOVEM T,(P)
AOS -1(P)
JRST EQLHN1
EQLHN2: SUB P,R70+4
POPJ P,
] ;END OF IFN HNKLOG
SUBTTL NCONC, *NCONC, APPEND, *APPEND, REVERSE, NREVERSE, NRECONC
NCONC: TDZA R,R ;LSUBR - DESTRUCTIVELY CATENATE LISTS
APPEND: MOVEI R,.APPEND-.NCONC ;LSUBR - CATENATE BY COPYING
JUMPE T,FALSE
POP P,B
APP2: AOJE T,BRETJ
POP P,A
PUSHJ P,.NCONC(R)
MOVE B,A
JRST APP2
.NCONC: JUMPE A,BRETJ ;SUBR 2 (*NCONC)
SKOTT A,LS
JRST NCNCER
.NCNC1: MOVEI TT,(A)
.NCNC2: MOVEI D,(TT)
HRRZ TT,(D)
JUMPN TT,.NCNC2
HRRM B,(D)
POPJ P,
.APPEND: JUMPE A,BRETJ ;SUBR 2 (*APPEND)
SKOTT A,LS
JRST APPERR
MOVEI C,AR1 ;MUST SAVE T,D - SEE MAKOBLIST
MOVE AR2A,A
APP1: HLRZ A,(AR2A)
PUSHJ P,CONS
HRRZ B,(A)
HRRM A,(C)
MOVE C,A
HRRZ AR2A,(AR2A)
JUMPN AR2A,APP1
AR1RETJ:
SUBS4: MOVEI A,(AR1)
POPJ P,
REVERSE: MOVEI C,(A) ;SUBR 1 - USES A,B,C
MOVEI A,NIL ;REVERSES A LIST BY CONSING UP A COPY
REV1: JUMPE C,CPOPJ ; OF THE TOP LEVEL IN REVERSE ORDER
HLRZ B,(C)
PUSHJ P,XCONS
HRRZ C,(C)
JRST REV1
NREVERSE: SETZ B, ;SUBR 1 - REVERSE A LIST USING RPLACD'S
NRECONC: JUMPE A,BRETJ ;SUBR 2 - (NRECONC X Y) = (NCONC (NREVERSE X) Y)
NREV1: HRRZ C,(A) ;ONLY 3 INSTRUCTIONS PER CELL! ZOOM!
HRRM B,(A)
JUMPE C,CPOPJ
HRRZ B,(C)
HRRM A,(C)
JUMPE B,CRETJ
HRRZ A,(B)
HRRM C,(B)
JUMPN A,NREV1
JRST BRETJ
SUBTTL GENSYM FUNCTION
GENSYM: JUMPN T,GENSY1
GENSY0: MOVE TT,[010700,,GNUM] ;STANDARD GENSYMER
GENSY4: MOVEI B,"0 ;WILL INCREMENT NUMERICAL PART
GENSY2: LDB T,TT ; AND GIVE OUT GENSYMED ATOM
AOS T
DPB T,TT
CAIG T,"9
JRST GENSY3
DPB B,TT
ADD TT,[070000,,0]
CAMGE TT,[350000,,]
JRST GENSY2
GENSY3: MOVE TT,GNUM
MOVEM TT,PNBUF
MOVEI C,PNBUF
JRST PNGNK2
GENSY1: MOVEI D,QGENSYM
AOJN T,S1WNALOSE
GENSY7: POP P,A
SKOTT A,FX
JRST GENSY5
MOVE TT,(A)
JUMPL TT,GENSY8
MOVE T,[010700,,GNUM]
GENSY6: IDIVI TT,10. ;INSTALL 4 DECIMAL DIGITS
ADDI D,"0 ; IN GENSYM COUNTER
DPB D,T
ADD T,[070000,,0]
CAMGE T,[350000,,]
JRST GENSY6
JRST GENSY3
GENSY5: TLNN TT,SY
JUMPN A,GENSY8
JSP T,CHNV1D
DPB TT,[350700,,GNUM]
JRST GENSY4
SUBTTL MEMBER, MEMQ, SUBST, DELQ, DELETE, *DELQ, *DELETE
MEMBER: SETZM MEMV ;USES A,B,AR1,AR2A,T,TT
MOVEI AR1,(A)
MOVEI AR2A,(B)
JSP T,LATOM
JRST MEMB1
SMEMQ: SETZM MEMV ;USES A,B,T,MUST PRESERVE AR1,AR2A;SEE GTSPC3
MEMQ2: SKOTT B,LS
JRST FALSE
HLRZ T,(B)
CAMN A,T
JRST SPROG2
HRRM B,MEMV
HRRZ B,(B)
JRST MEMQ2
MEMB1: SKOTT AR2A,LS
JRST FALSE
MOVE A,AR1
HLRZ B,(AR2A)
PUSHJ P,EQUAL
JUMPN A,MEMB2 ;TRUE
HRRM AR2A,MEMV
HRRZ AR2A,(AR2A)
JRST MEMB1
AR2ARETJ:
MEMB2: MOVEI A,(AR2A)
POPJ P,
SUBST: SKIPA AR1,A
SUBS0A: SKIPA A,AR1
SKIPA AR2A,B
MOVE B,AR2A
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,AR1RETJ
SUBS1: MOVE A,C
PUSHJ P,ATOM
JUMPE A,SUBS2
CRETJ:
SPROG3: MOVE A,C
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
SUBS3: POP P,B
JRST XCONS
DELQ: SKIPA D,[SMEMQ] ;USES A,B,C,T,TT. MUST SAVE AR2A - SSMACRO
DELETE: MOVEI D,MEMBER ;USES A,B,C,AR1,AR2A,T,TT
MOVEI TT,-1 ;MUST SAVE R, SEE GCP6H1
CAMN T,XC-2
JRST DLT3
CAME T,XC-3
JRST DLT6
POP P,A
JSP T,FLTSKP
JRST .+2
JSP T,IFIX
DLT3: MOVEM TT,DLTC
MOVEI TT,(P)
SKIPA B,(P)
DLT2: HRRM B,(TT)
MOVEM TT,TABLU1
MOVE A,-1(P)
SOSGE DLTC
JRST DLT1
PUSHJ P,(D) ;MEMBER OR MEMQ
JUMPE A,DLT1
HRRZ B,(A)
SKIPN TT,MEMV
MOVE TT,TABLU1
JRST DLT2
DLT1: POP P,A
JRST POP1J
.DELQ: SKIPA D,[SMEMQ]
.DELETE: MOVEI D,MEMBER
PUSH P,A
PUSH P,B
MOVEI TT,-1
JRST DLT3
MEMQ: JUMPE B,FALSE
HLRZ T,(B)
CAIN T,(A)
JRST BRETJ
HRRZ B,(B)
JRST MEMQ
SUBTTL FLOATP, FIXP, NUMBERP, TYPEP, AND PDLNMK ROUTINE
IRP NUMP,,[FIXP,FLOATP,NUMBERP]BITS,,[FX+BN,FL,FX+FL+BN]
NUMP: SKOTT A,BITS
JRST FALSE ;RETURN NIL IF NOT OF DESIRED TYPE
MOVE TT,(A) ;RETURN T IF WHAT WE WANT. ALSO, TT GETS THE NUMBER.
JRST TRUE ;IF NUMBERP GETS A BIGNUM, TT GETS THE CORRECT SIGN, ANYWAY
TERMIN
TYPEP: JUMPE A,TYPNIL ;SUBR 1 - USES ONLY A
ROT A,-SEGLOG
HRRZ A,ST(A)
POPJ P,
TYPNIL: MOVEI A,QSYMBOL
POPJ P,
NMCK0: POP P,A
NUMCHK: ;CHECK TO SEE THAT WE HAVE A NUMBER, THEN EXIT
BG% JSP T,FLTSKP
BG$ JSP T,NVSKIP
BG$ POPJ P,
JFCL ;FALLS INTO PDLNKJ
PDLNKJ: MOVEI T,CPOPJ ;PDLNKJ = PDLNMK, THEN POPJ P,
PDLNMK: CAML A,NPDLL
CAMLE A,NPDLH
JRST (T)
ROT A,-SEGLOG
SPECPRO INTROT
HLL T,ST(A)
ROT A,SEGLOG
NOPRO
TLNN T,$FXP+$FLP ;SKIP IFF PDL NUMBER
JRST (T)
PUSH P,T
NMK1: MOVEM TT,PNMK1 ;EXPECTS TYPE BITS IN T
MOVE TT,(A)
HRRI T,PNMK2 ;MUST SAVE TT
TLNN T,$FLP ;FIGURE OUT WHICH KIND OF CONS TO DO
JRST FXCONS ; - FIXNUM
JRST FLCONS ; - FLONUM
PNMK2: MOVE TT,PNMK1 ;RESTORE TT FOR PDLNMK
CPDLNKJ: POPJ P,PDLNKJ
SUBTTL GCPRO AND SXHASH
GCPRO: JUMPE B,GCREL
CAIN B,QM ;SECOND ARG = ? MEANS ONLY GCLOOK
JRST GCLOOK
%GCPRO: MOVEI AR1,1 ;MUST SAVE R,F - FOR FASLOAD
GCPR1: CAIL A,IN0-XLONUM
CAILE A,IN0+XHINUM-1
JRST .+2
POPJ P,
SKOTT A,SY
JRST GCPR2
JUMPLE AR1,CPOPJ
HLRZ T,(A)
MOVSI TT,100 ;COMPILED CODE NEEDS ME BIT
MOVSI D,200 ;PURE SYMBOL BLOCK BIT
TDNN D,(T)
IORM TT,(T)
POPJ P,
GCPR2: MOVE AR2A,A ;SAVE ARG
PUSHJ P,SXHSH0 ;LEAVES HASHKEY IN D
MOVE A,AR2A
MOVE T,AR1 ;T=0 => RELEASE, ELSE PROTECT
.GCPRO: JUMPE A,CPOPJ
LOCKI
PUSH P,A ;PLACES ORIG ARG ON PDL
PUSHJ P,SAVX5 ;SAVES NUM ACS
SKIPE B,GCPSAR
JRST .GCPR5
MOVEI A,NIL
MOVE TT,LOSEF
ADDI TT,1
LSH TT,-1
PUSHJ P,MKLSAR
MOVE D,-2(FXP) ;RESTORE HASHKEY IN D
MOVEM B,GCPSAR
.GCPR5: MOVE T,D ;ARG ON P, AND SAVES NUM ACS ON FXP
LSH T,-1
IDIV T,LOSEF
PUSH FXP,TT
MOVEI A,(FXP)
PUSHJ P,@ASAR(B)
SUB FXP,R70+1
MOVEM R,-3(FXP)
MOVE B,A
MOVE A,(P) ;ORIG ARG ON P
PUSH P,B ;SAVE PROLIST BUCKET
SKIPN -4(FXP)
JRST GCRL1 ;GO RELEASE IF FLAG SO SET.
PUSHJ P,MEMBER
JUMPN A,GCPR3 ;ITEM ALREADY IN PROTECTIVE BUCKET
SKIPG -4(FXP)
JRST GCPR4
MOVE A,-1(P) ;ORIGINAL ARG
MOVE B,(P) ;CONSED ONTO PROLIST BUKET
PUSHJ P,CONS
MOVE R,-3(FXP)
HRRZ D,GCPSAR
JSP T,.STOR0
GCPR3: HLRZ A,(A)
GCPR4: PUSHJ P,RSTX5
SUB P,R70+2
UNLKPOPJ
GCRL1: CALLF 2,QDELETE ;GCRELEASE
MOVE R,-3(FXP)
HRRZ D,GCPSAR
JSP T,.STOR0
JRST GCPR4
GCREL: TDZA AR1,AR1
GCLOOK: MOVNI AR1,1
SKIPN GCPSAR
JRST FALSE
JRST GCPR1
SXHASH: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE
PUSHJ P,SXHSH0 ;SAVE F - SEE DEFUN
MOVE TT,D
POPJ P,
ATMHSH: ;HASH A PRINT NAME
BNHSH: SETZ T, ;HASH A BIGNUM (SAME ALGORITHM)
SKIPA B,A
AHSH1: HRRZ B,(B)
JUMPE B,AHSH2
HLRZ C,(B)
XOR T,(C)
JRST AHSH1
AHSH2: LSH T,-1 ;FOR ATOMS, THIS INSURES THAT THE HASHKEY IS POSITIVE
JRST (TT)
NILHSH: MOVE D,[<ASCII \NIL\>←-1] ;HASH NIL FASTLY
POPJ P,
SXHSH0: JUMPE A,NILHSH ;RETURNS S-EXPR'S HASHKEY IN D
SKOTT A,LS
2DIF JRST @(TT),SXHSH9-1,QLIST .SEE STDISP
HRRZ B,(A)
PUSH P,B
HLRZ A,(A)
PUSHJ P,SXHSH0
ROT D,-1
PUSH FXP,D
POP P,A
PUSHJ P,SXHSH0
POP FXP,T
ADD D,T
POPJ P,
SXHSH8: MOVM D,(A) ;FLONUM
POPJ P,
SXHSH7: MOVE D,(A) ;FIXNUM
POPJ P,
IFN BIGNUM,[
SXHSH4: HRRZ A,(A) ;BIGNUM
JSP TT,BNHSH
MOVE D,T
POPJ P,
] ;END OF IFN BIGNUM
SXHSH5: HLRZ T,(A) ;SYMBOL
HRRZ A,1(T)
JSP TT,ATMHSH
SKIPA D,T
SXHSH6: MOVEI D,(A)
POPJ P, ;RANDOM, ARRAY
SXHSH9: SXHSH7 ;FIXNUM
SXHSH8 ;FLONUM
BG$ SXHSH4 ;BIGNUM
SXHSH5 ;SYMBOL
REPEAT HNKLOG, SXHS1A ;HUNKS
SXHSH6 ;RANDOM
SXHSH6 ;ARRAY
IFN .-SXHSH9-NTYPES+1, WARN [WRONG LENGTH TABLE]
IFN HNKLOG,[
SXHS1A: MOVSI T,-2
2DIF [LSH T,(TT)]0,QHUNK1
PUSH P,A
HRRI T,(A)
PUSH P,T
PUSH FXP,R70
SXHS1B: HLRZ A,(T)
PUSHJ P,SXHSH0
ROT D,1
ADDM D,(FXP)
MOVE T,(P)
HRRZ A,(T)
PUSHJ P,SXHSH0
ADD D,(FXP)
ROT D,2
MOVEM D,(FXP)
MOVE T,(P)
AOBJP T,SXHS1F
MOVEM T,(P)
JRST SXHS1B
SXHS1F: SUB P,R70+2
JRST POPXDJ
] ;END OF IFN HNKLOG
SUBTTL MAPPING FUNCTIONS
;;; MAPATOMS FUNCTION
;;; (MAPATOMS FN) CALLS FN REPEATEDLY, FEEDING IT SUCCESSIVE
;;; ATOMS FROM THE CURRENT OBARRAY. OPTIONAL SECOND ARG
;;; SPECIFIES OBARRAY (MUST BE A SAR!). RETURNS NIL.
MAPATOMS:
MOVEI D,QMAPATOMS
AOJG T,S1WNALOSE
AOJL T,S2WNALOSE
SKIPE T ;SECOND ARG DEFAULTS TO
PUSH P,VOBARRAY ; CURRENT OBARRAY
MOVEI TT,(CALL 1,)
HRLM TT,-1(P)
PUSH P,R70
PUSH FXP,[OBTSIZ] ;NUMBER OF BUCKETS
MAPAT1: SOSGE TT,(FXP) ;TT GETS BUCKET NUMBER
JRST MAPAT9
HRRZ AR1,-1(P)
ROT TT,-1
HLRZ A,@TTSAR(AR1) ;FETCH BUCKET
SKIPGE TT
HRRZ A,@TTSAR(AR1)
MOVEM A,(P) ;SAVE BUCKET
MAPAT2: SKIPN B,(P) ;MAPCAR DOWN BUCKET
JRST MAPAT1
HLRZ A,(B)
HRRZ B,(B)
MOVEM B,(P)
XCT -2(P) ;CALL SUPPLIED FUNCTION
JRST MAPAT2
MAPAT9: SUB FXP,R70+1 ;EXIT, RETURNING NIL
SUB P,R70+3
JRST FALSE
;;; PDL STRUCTURE FOR MAP SERIES
;;; ,,RETURN ;LEFT HALF MAY HAVE BAKTRACE INFO
;;; ,,EVENTUAL VALUE ;LEFT HALF HAS LAST OF VALUE LIST
;;; LIST1 ;SECOND ARG
;;; LIST2 ;THIRD ARG
;;; LIST3 ;FOURTH ARG
;;; ...
;;; LISTN ;LAST ARG
;;; -N,,<ADDRESS OF LIST1 ON STACK>
;;; CODE,,MODE ;CODE TELLS WHAT KIND OF MAP, MODE TELLS HOW TO CALL FN
;;; ; (MODE IS ADDRESS OF PLACE WHICH SETS UP ARGS FOR FN)
;;; MAPL6 ;OR MAYBE MAPL3 - THIS IS WHERE FN CALL RETURNS TO
;;; JCALL K,FN ;FN=FIRST ARG - K=1,2,3,4,5, OR 16
;;; ;UUO HANDLER MAY CLOBBER THIS WITH A JRST
;;; ;IF NEVER GOING TO BE XCT'ED, JCALL NEED NOT BE THERE
MAPLIST: JSP TT,MAPL0 ;CODE 0
MAPCAR: JSP TT,MAPL0 ;CODE 1
MAP: JSP TT,MAPL0 ;CODE 2
MAPC: JSP TT,MAPL0 ;CODE 3
MAPCON: JSP TT,MAPL0 ;CODE 4
$MAPCAN: JSP TT,MAPL0 ;CODE 5
MAPL0: AOJGE T,MAPWNA ;LOSE IF ONLY ONE ARG
MOVE D,T
ADDI D,1(P) ;D HAS ADDRESS OF LIST1 ON STACK
HRLI D,(T)
PUSH P,D
10$ SUBI TT,MAPLIST ;LOSING D10 DISALLOWS
10$ MOVSI TT,-1(TT) ; NEGATIVE RELOCATION
.ELSE MOVSI TT,-MAPLIST-1(TT) ;FIGURE OUT CODE FOR WHICH KIND OF MAP
PUSH P,TT ;SAVE CODE - FIGURE OUT MODE LATER
TLNE TT,2 ;SKIP IF WE'LL BE SAVING UP RESULTS
SKIPA A,(D) ;ELSE WE'LL JUST RETURN FIRST LIST AS VALUE
MOVSI A,-1(D)
EXCH A,-1(D) ;INIT EVENTUAL VALUE SLOT - A NOW HAS FIRST ARG (FN)
JSP T,SPATOM
JRST MAPL5 ;FOOEY, IT'S NOT A SYMBOL
HRRZ C,(A)
MAPL1: JUMPE C,MAPL5 ;FOOEY, IT'S A SYMBOL WITH NO FUNCTION PROPERTY
HLRZ B,(C)
HRRZ C,(C)
HRRZ C,(C)
CAIL B,QARRAY ;REMEMBER, SYMBOLS DENOTING FUNCTION PROPS
CAILE B,QFEXPR ; ARE CONSECUTIVE IN SYMBOL SPACE
JRST MAPL1
CAIE B,QARRAY
CAIN B,QSUBR
JRST MAPL5A ;GO FIGURE OUT JCALL FOR A SUBR OR ARRAY
CAIE B,QLSUBR
JRST MAPL5 ;FOOEY, IT'S SOMETHING WE CAN'T LINK TO WELL
PUSH P,CMAPL3
HRLI A,(JCALL 16,)
MOVEI B,MAPL23
MAPL1B: HRRM B,-1(P) ;B HAS MODE - SAVE IT
PUSH P,A ;SAVE FN (MAYBE WITH JCALL K, IN LEFT HALF)
JRST MAPL2
MAPL3: MOVE D,(P) ;GET FUNCTION CALL FROM STACK
TLNE D,700000 ;SKIP IF IT DIDN'T GET CLOBBERED
JRST MAPL3A
MOVEI D,MAPL24 ;OH, WELL! MIGHT AS WELL USE MODE
HRRM D,-2(P) ; FOR UNCLOBBERABLE FNS
CMAPL6:
MAPL3A: MOVEI D,MAPL6
MOVEM D,-1(P) ;WE ONLY NEED TO DO A MAPL3 CHECK ONCE
MAPL6: MOVE D,-3(P) ;D POINTS TO LIST1 ON STACK
HLRZ C,-1(D) ;C GETS POINTER TO LAST OF VALUE
JUMPE C,MAPL7 ;THIS IS REALLY A MAP OR MAPC
HLLZ B,-2(P) ;GET CODE IN LAFT HALF OF B
TLNE B,4
JRST MAPL8 ;MAPCAN OR MAPCON
PUSHJ P,CONS ;MAPCAR OR MAPLIST - NOTE THAT B IS NIL
HRRM A,(C) ;CLOBBER INTO END OF LIST
MAPL6A: HRLM A,-1(D) ;SAVE NEW LAST POINTER
MAPL7: MOVE TT,(D)
MAPL7A: HRRZ A,(TT) ;TAKE CDR OF ALL LISTS
MOVEM A,(D)
SKIPL TT,1(D)
AOJA D,MAPL7A
MOVE D,TT ;NOW D POINTS TO LIST1 ON STACK AGAIN
MAPL2: MOVE B,-2(P)
MOVE C,P ;SAVE C FOR A QUICK GETAWAY
PUSH P,-1(P) ;WHERE CALL TO FN SHOULD RETURN
MAPL21: SKIPG A,(D) ;D POINTS TO VECTOR OF LISTS
JRST MAPL22 ;REMEMBER, <-N,,XXX> IS JUST AFTER <LISTN>
MOVEI TT,(A)
LSH TT,-SEGLOG
SKIPL ST(TT) ;END-OF-LIST TEST
JRST MAPL40
TLNE B,1 ;SKIP UNLESS THIS IS A "CAR" KIND OF MAP
HLRZ A,(A)
PUSH P,A ;PUSH ARG
AOJA D,MAPL21 ;IF NOT END, GO CHECK OUT NEXT LIST
MAPL40: JUMPE A,MAPL4
LER3 [SIXBIT \NON-NULL TERMINATION OF LIST - MAP\]
MAPL4: MOVE P,C ;THIS POPS OFF FASTLY ANY UNNEEDED STUFF
HLRZ T,-3(P) ;GET -N IN T
SUBI T,4
HRLI T,-1(T)
ADD P,T ;FASTLY POP OFF FN, MODE, ALL LISTS, ETC.
POP P,A ;FINAL VALUE GOES IN A
TLZ A,-1 ;ZERO ANY LEFT HALF GARBAGE
CMAPL3: POPJ P,MAPL3 ;HOORAY!
MAPL22: JUMPE A,MAPL4 ;NIL IS NORMAL END-OF-LIST
SETZB A,B ;MAY HAVE GARBAGE IN LEFT HALVES
HLRE T,(D) ;T GETS -N IN CASE OF LSUBR CALL
MOVE TT,1(D) ;GET MODE (D POINTS TO <-N,,XXX> ON STACK)
JSP R,(TT) ;FOR SUBRS, GOES TO PDLA2-N
MAPL23: XCT 3(D) ;GO HERE FOR LSUBRS
MAPL24: MOVEM T,UUTSV ;GO HERE FOR UNCLOBBERABLE CALL
MOVE T,3(D) ;SAVE SOME OF THE UUOH TROUBLE BY
HRLI T,(JCALLF 16,) ; ENTERING THE UUO MESS MORE DIRECTLY
MOVEM T,40
TLZ T,-1
MOVEI R,1 ;R=1 MEANS LSUBR CALL
SETZM UUOH
JRST UUOH0A
MAPL5: PUSH P,CMAPL6 ;SET UP FOR UNCLOBBERABLE FN CALL
MOVEI B,MAPL24
JRST MAPL1B
MAPL5A: HLRE T,-1(P)
CAMGE T,XC-5 ;CHECK NUMBER OF ARGS FOR FN
JRST MAPL5 ;FOOEY, TOO MANY ARGS FOR SUBR CALL
PUSH P,CMAPL3
MOVM TT,T
LSH TT,5
TLO A,(JCALL)(TT) ;MAKE UP JCALL OF RIGHT # OF ARGS
MOVEI B,PDLA2(T) ;MODE = PDLA2-<# OF ARGS>
JRST MAPL1B
MAPL8: JUMPE A,MAPL7 ;NCONC'ING NIL DOES VERY LITTLE
HRRM A,(C) ;CLOBBER INTO LAST OF PREVIOUS THING
PUSHJ P,LAST ;FIND LAST OF THIS NEW FROB
JRST MAPL6A
.MAP: JSP TT,.MAP1 ;MAPCAN
JSP TT,.MAP1 ;MAPCON
JSP TT,.MAP1 ;MAPC
JSP TT,.MAP1 ;MAP
JSP TT,.MAP1 ;MAPCAR
JSP TT,.MAP1 ;MAPLIST
.MAP1: JUMPE A,CPOPJ
TLNE A,-1 ;RIDICULOUS CHECK FOR HORRIBLE
.VALUE ; COMPILER LOSSES
PUSH P,B ;LIST IN A, FUNCTION IN B,
PUSH P,A ;NUMBER IN TT IS INDEX
MOVNI T,2
10$ SUBI TT,.MAP+A ;LOSING D10!!!
10$ MOVNS TT ;NO NEGATIVE RELOC ALLOWED!
.ELSE MOVNI TT,-.MAP-A(TT)
JRST $MAPCAN(TT)
SET: JSP D,SETCK
EXCH B,AR1
JSP T,.SET1
EXCH B,AR1
POPJ P,
%WTA NASER
SETCK: JSP T,SPATOM
JRST .-2
JRST (D)
SUBTTL VARIOUS BREAK ROUTINES
$BREAK: JUMPE A,CPOPJ ;*BREAK - SUBR 2
$BRK0: MOVEI A,(B) ;A = BREAKP, B = BREAKID
HRRZ B,V.
MOVEI C,TRUTH
HRRZ AR1,VIPLUS
HRRZ AR2A,VIDIFF
JSP T,SPECBIND ;DO *NOT* BIND ↑R
TAPRED ;↑Q
TTYOFF ;↑W
Q% TYIMAN
Q% TMBBC
VEVALHOOK ;EVALHOOK
0 B,V. ;*
0 C,V%TERPRI
0 AR1,VIPLUS ;+
0 AR2A,VIDIFF ;-
IFN QIO,[
MOVEI B,$DEVICE
MOVEI C,UNTYI
;; MOVEI AR1,READP
;; MOVEI AR2A,UNRD
JSP T,SPECBIND
0 B,TYIMAN
0 C,UNTYIMAN
;; 0 AR1,READPMAN
;; 0 AR2A,UNREADMAN
] ;END OF IFN QIO
Q% SETZM RDOBCT
STRT 17,[SIXBIT \↑M;BKPT !\]
Q% PUSHJ P,PRINC ;PRINC BREAK ID
Q$ HRRZ AR1,VMSGFILES
Q$ TLO AR1,200000
Q$ PUSHJ P,$PRINC
STRT 17,STRTCR
MOVE A,VIDIFFERENCE
MOVEM A,VIPLUS
MOVEI D,BRLP ;FUNCTION TO EXECUTE
PUSHJ P,BRGEN ;CATCH AND ERRSET AROUND A READ-EVAL-PRINT LOOP
Q% SKIPN LINMODE
Q$ JSP F,LINMDP
PUSHJ P,ITERPRI
Q$ PUSHJ P,UNBIND
JRST UNBIND
CB: SKIPN V.RSET ;CALL BREAK - *RSET ERROR
POPJ P,
SKIPA B,[Q.R.TP]
Q% CN.HB: MOVEI B,QCN.H ;CONTROL-H BREAK
Q$ CN.BB: MOVEI B,QCN.B ;CONTROL-B BREAK
PUSHJ P,IOGBND
Q$ PUSH P,CUNBIND
JRST BKCOM2
UDFB: MOVEI B,QUDF ;UNDEFINED FUNCTION BREAK
JRST BKCOM
UBVB: MOVEI B,QUBV ;UNBOUND VARIABLE BREAK
JRST BKCOM
WTAB: MOVEI B,QWTA ;WRONG TYPE OF ARGUMENT BREAK
JRST BKCOM
UGTB: MOVEI B,QUGT ;UNSEEN GO TAG BREAK
JRST BKCOM
WNAB: MOVEI B,QWNA ;WRONG # ARGS BREAK
JRST BKCOM
GCLB: MOVEI B,QGCL ;FAILED TO GARBAGE-COLLECT ENOUGH SPACE BREAK
JRST BKCOM
PDLB: MOVEI B,QPDL ;PDL OVERFLOW BREAK
JRST BKCOM
GCOB: MOVEI B,QGCO ;GC OVERFLOW BREAK
JRST BKCOM
Q$ IOLB: MOVEI B,QIOL ;I/O LOSSAGE BREAK
Q$ JRST BKCOM
FACB: MOVEI B,QFAC ;FAILED ACTION REQUEST BREAK
BKCOM:
Q% PUSHJ P,IOGBND
SAVE A B
Q% MOVEI A,NIL
Q% PUSHJ P,ERRPRINT
IFN QIO,[
PUSH P,CBKCM0
PUSH P,R70
PUSH P,VMSGFILES
MOVNI T,2
JRST ERRPRINT
BKCOM0:
] ;END OF IFN QIO
JSP R,RSTR2
BKCOM2: MOVEI AR1,READTABLE
MOVEI AR2A,OBARRAY
JSP T,SPECBIND
0 A,VARGS ;SPECIAL VALUE CELL OF ARGS
0 AR1,VREADTABLE ;RESET READTABLE AND OBARRAY
0 AR2A,VOBARRAY ; TO STANDARD (INITIAL) ONES
Q% SETZ A,
Q$ CBKCM0: SETZ A,BKCOM0
PUSHJ P,NOINTERRUPT
MOVEI A,TRUTH
PUSHJ P,$BREAK
BKCOM1:
Q% PUSHJ P,UNBIND
JRST UNBIND
SUBTTL INTERN FUNCTION AND RELATED ROUTINES
INTERN: PUSH P,A ;ONLY INIT ENTERS INTERN AT INTRN0
INTRN3: PUSHJ P,PNGET ;MUST SAVE F - SEE FASLOAD
SETOM LPNF
INTRN1: SETZM RINF
JSP TT,ATMHSH ;LEAVES ATOM'S HASHKEY IN T
MOVEI AR2A,(A)
HLRZ C,(A)
INTRN: TLZ T,400000
IDIVI T,OBTSIZ
HRLM TT,(P)
INTRN4: LOCKI ;SO THAT NO INTERRUPT SNEAKS SOMETHING
SKIPN D,VOBARRAY ; ON THE OBLIST JUST AFTER WE DECIDE IT ISNT THERE
JRST INTNCO
MOVEI C,(D)
LSH C,-SEGLOG
MOVE C,ST(C)
TLNN C,SA
JRST INTNCO
MOVE T,ASAR(D)
TLNN T,AS<OBA>
JRST INTNCO
ROT TT,-1 ;GET BUCKET
JUMPL TT,.+3
HLRZ A,@TTSAR(D)
JRST .+2
HRRZ A,@TTSAR(D)
PUSH FXP,TT
JUMPE A,MAKA0
MOVEI C,A
MAKF: MOVE AR1,C
HRRZ C,(C)
JUMPE C,MAKA
HLRZ AR1,(C)
SKIPN AR1
TROA AR1,$$$NIL ;BEWARE THE SKIP!
MAKF1: HLRZ AR1,(AR1)
HRRZ AR1,1(AR1)
SKIPN T,RINF ;RINF HAS ZERO WHEN IN REGULAR INTERN
MOVEI T,(AR2A)
MAK2: JUMPE AR1,MAK1
JUMPE T,MAKF
HLRZ B,(AR1)
MOVE B,(B)
SKIPN RINF
JRST MAK4
CAME B,@RNTN2 ;<END OF PNAME>(T)
JRST MAKF ;COMPARE FOR RINTERN
AOJA T,MAK3
MAK4: HLRZ D,(T) ;COMPARE FOR REGULAR INTERN
CAME B,(D)
JRST MAKF
HRRZ T,(T)
MAK3: HRRZ AR1,(AR1)
JRST MAK2
MAKA3: HRRZ A,(P)
SKIPL LPNF
PUSHJ P,SYCONS
JRST MAKA2
MAKA0: TDZA D,D ;D=0 => BUCKET WAS EMPTY BEFORE THIS CALL
MAKA: MOVEI D,1
MOVN C,RINF ;MAKE-UP NEW ATOM
JUMPE C,MAKA3
PUSHJ P,PNGNK
MAKA2: PUSHJ P,NCONS
MOVE TT,(FXP)
JUMPE D,MAKA5
HRRM A,(AR1) ;NCONC ONTO END OF BUCKET
JRST MAKA4
MAKA5: HRRZ D,VOBARRAY
JUMPL TT,.+3
HRLM A,@TTSAR(D)
JRST .+2
HRRM A,@TTSAR(D)
MAKA4: SKIPA C,A
MAK1: JUMPN T,MAKF ;ATOM FOUND ON OBLIST
HLRZ A,(C)
POP FXP,TT ;SHOULD EXIT WITH OBTBL BUCKET # IN TT
SUB P,R70+1
UNLKPOPJ
RINTERN: CAMN C,[350700,,PNBUF]
JRST RINTN1
RINTN0: PUSH FXP,T
PUSH P,CPXTJ
PUSH P,A ;ENTERING INTERN AFTER THE "PUSH P A", SO MUST DO HERE
SKIPL LPNF
JRST INTRN1
ADDI C,1
HRRM C,RNTN2
10% MOVEI C,-PNBUF(C) ;MOVEI IS FASTER THAN SUBI
10$ SUBI C,PNBUF ;FOOBAR! NO NEG RELOC ALLOWED FOR D10
10$ TLZ C,-1 ;MAY BE CRUFT IN LH (LIKE BYTE POINTER)
MOVNM C,RINF
INTRN2: MOVEI C,PNBUF ;DUPLICATE PNAME HASHING ALGORITHM
MOVE T,PNBUF ; AS USED IN SXHASH
MOVN D,RINF
SOJLE D,.+3
XOR T,PNBUF(D)
JRST .-2
LSH T,-1
JRST INTRN
RINTN1: SKIPL LPNF
JRST RINTN0
MOVE TT,PNBUF
ROT TT,6
ADDI TT,<OBTSIZ+1>/2 ;### OBTSIZ MUST BE ODD
MOVE D,VOBARRAY
JUMPL TT,.+3
HLRZ A,@1(D)
JRST .+2
HRRZ A,@1(D)
JUMPN A,CPOPJ
PUSH FXP,TT
PUSHJ P,RINTN0
POP FXP,TT
MOVE D,VOBARRAY
JUMPL TT,.+3
HRLM A,@1(D)
POPJ P,
HRRM A,@1(D)
POPJ P,
IMPLODE: SKIPA T,CRINTERN ;SUBR 1
MAKNAM: MOVEI T,PNGNK1 ;SUBR 1
JUMPE A,MKNM4
PUSH P,T
Q% PUSH P,MKNM3
Q% HRRZM A,MKNM3
Q$ PUSH P,RDLARG
Q$ HRRZM A,RDLARG
MOVEI T,MKNM1
PUSHJ FXP,MKNR6C
Q% POP P,MKNM3
Q$ POP P,RDLARG
CRINTERN: POPJ P,RINTERN
IFN QIO,[
MKNM1: SKIPN A,RDLARG
POPJ P,
HRRZ B,(A)
MOVEM B,RDLARG
HLRZ A,(A)
MKNM2: JSP T,CHNV1
JRST POPJ1
] ;END OF IFN QIO
IFE QIO,[
MKNM1: SKIPN B,MKNM3 ;GET NEXT CHAR FOR MAKNAM
JRST FALSE
MKRL1: HRRZ A,(B)
HRRM A,MKNM3
HLRZ A,(B) ;B HOLDS LIST FROM WHICH TO GET NEXT CHAR FOR
JSP T,CHNV1
MOVEI A,(TT)
POPJ P,
] ;END OF IFE QIO
RDL12: MOVEI T,RINTERN
MKNM4: SETZM PNBUF
JSP TT,IRDA
JRST (T) ;PNGNK1 OR RINTERN, THEN POPJ P,
;;; GET CHARACTER NUMERIC VALUE
CHNV1X: TLO T,1
CHNV1: SKOTT A,SY+FX
JRST CHNV1C
TLNN TT,SY
JRST CHNV1A
CHNV1D: HLRZ TT,(A)
HRRZ TT,1(TT)
HLRZ TT,(TT)
LDB TT,[350700,,(TT)]
JRST CHNV1B
CHNV1A: MOVE TT,(A)
TLNN T,1
CHNV1B: TDNN TT,[-200]
JRST (T)
CHNV1C: WTA [NOT ASCII CHARACTER!]
JRST CHNV1
SUBTTL DEFPROP AND DEFUN
DEFPROP: PUSH P,A
JSP T,DFPR2
JSP T,DFPR1
JRST DFPER
HRRZ TT,(C)
JUMPN TT,DFPER
HLRZ A,(A)
HLRZ AR1,(B)
HLRZ B,(C)
MOVEI C,(B)
DEF1: MOVEI AR2A,(A)
DEF1B: PUSHJ P,REMPROP ;REMPROP SAVES C, AR1, AR2A
MOVEI B,(AR1)
JUMPN A,DEF1B ;REMOVE ALL OCCURRENCES OF THE PROPERTY
MOVEI A,(AR2A)
PUSHJ P,PUTPROP
DEF9: POP P,A
$CAR: HLRZ A,(A)
C$CAR: POPJ P,$CAR
DFPR2: HLRZ B,(A) ;SOME HAIRY CHECKS FOR DEFPROP AND DEFUN
SKOTT B,SY
JUMPN B,1(T)
JRST (T)
DFPR1: JUMPE A,(T) ;MORE HAIRY CHECKS FOR DEFPROP AND DEFUN
HRRZ B,(A) ;SKIPS ON *SUCCESS*
JUMPE B,(T) ;LEAVES STUFF SPREAD OUT IN A, B, C
HRRZ C,(B)
JUMPE C,(T)
JRST 1(T)
DEFUN: PUSH P,A ;FEXPR
HLRZ AR1,(A)
CAIL AR1,QEXPR ;REMEMBER, (QEXPR, QFEXPR, QMACRO)
CAILE AR1,QMACRO ; ARE IN THAT ORDER
JRST DEF7
HRRZ A,(A) ;(DEFUN FEXPR FOO (L) EXPRESSIONS)
HRRM A,(P)
JRST DEF3
DEF7: HRRZ A,(A)
HLRZ AR1,(A)
CAIGE AR1,QEXPR
JRST DEF8
CAIG AR1,QMACRO
JRST DEF3 ;(DEFUN FOO FEXPR (L) EXPRESSIONS)
DEF8: MOVEI AR1,QEXPR ;(DEFUN FOO (L) EXPRESSIONS)
MOVE A,(P)
DEF3: JSP T,DFPR1
JRST DEFNER
MOVEI A,QLAMBDA
PUSHJ P,CONS ;CLOBBERS TT
MOVEI C,(A)
HRRZ A,(P)
JSP T,DFPR2 ;CHECK TO SEE IF ATOM
JRST DEF3A
JUMPE B,DEFNER
HRRZ AR1,(B) ;PECULIAR 3-LIST FORMAT:
HLRZ AR1,(AR1) ; (NAME EXPRNAME SUBRNAME)
JUMPE AR1,DEFNER
HRRM B,(P)
DEF3A: SKIPE VDEFUN ;THE VALUE OF DEFUN CONTROLS
JRST DEF6 ; THE EXPR-HASH HACK
DEF5: HLRZ A,@(P)
EXCH C,AR1
MOVEI B,(C)
JRST DEF1
DEF4: HRRZ A,(A) ;(DEFUN FEXPR FOO (L) EXPRESSION)
HRRM A,(P)
JRST DEF3
DEF6: HLRZ A,@(P)
MOVEI B,QXPRHSH ;EXPR-HASH
PUSHJ P,GET1 ;GET EXPR-HASH PROPERTY
JUMPE A,DEF5 ;DO DEFUN IF NONE
MOVE F,(A)
PUSH P,C
MOVEI A,(C) ;CANONICAL LAMBDA FORM
PUSHJ P,SXHASH+1 ;NCALL 1,.FUNCTION SXHASH
POP P,C
CAMN TT,F
JRST DEF9 ;AHA! HASHES MATCH! FORGET IT.
HLRZ A,@(P) ;HASHES DON'T MATCH,
MOVEI B,QXPRHSH ; SO REMOVE THE
PUSHJ P,REMPROP ; EXPR-HASH PROPERTY,
JRST DEF5 ; AND DO THE DEFUN AFTER ALL
SUBTTL TYIPEEK FUNCTION
IFE QIO,[
TYIPEEK: SKIPA D,[MAKNUM]
MOVEI D,A2TT
AOJL T,TYPKER
MOVNI TT,1 ;-1 => NO ARG, SO ANY NEXT CHAR IS TAKEN
JUMPN T,TYPK4D
TYPK4: POP P,A ;IF ARG GIVEN, THEN SCAN UNTIL SPECIFIC KIND OF CHAR IS FOUND
MOVNI TT,2 ;-2 => ARG OF T GIVEN
CAIN A,TRUTH ;ARG OF T MEANS SCAN FOR READ STARTUP CHAR
JRST TYPK4D
JSP T,FXNV1 ;IF ARG >777, THEN IT IS SYNTAX TYPE OF CHAR TO FIND
CAIGE TT,1000 ;IF ARG < 1000, THE IT IS SPECIFIC CHAR'S ASCII VALUE
JRST TYPK4D
NW% LSH TT,-9.
TLO TT,400000
TYPK4D: PUSH P,D
PUSH FXP,TT
JSP T,RSXST
TYPK4A: SKIPN A,TYIMAN
JRST TYPK5
PUSHJ P,(A)
CAIN A,203 ;PSEUDO-SPACE AT END OF STREAM
MOVEI A,↑C
CAIN A,↑C
JRST TYPK3B
PUSHJ P,TYPK7
JRST TYPK4A
MOVEM A,TMBBC
TYPX: SUB FXP,R70+1
POPJ P,
TYPK5: SKIPN TAPRED
JRST TYPK6
TYPK5A: PUSHJ P,URED
JRST TYPK3
PUSHJ P,TYPK7
JRST TYPK5A
EXCH A,C
PUSHJ P,READ3 ;BACK UP UTIBP
EXCH A,C
JRST TYPX
TYPK3: JSP A,.UEOF
TYPK3B: MOVEI A,3 ;3 IS ASCII E-O-F
JRST TYPX
;;; IFE QIO
TYPK6: SKIPE A,RDTYBF
JRST TYPK6A
TYPK6B: PUSHJ P,TYIN
PUSHJ P,TYPK7
JRST TYPK5
MOVEM A,PBFTY
JRST TYPX
TYPK6A: HLRZ A,(A)
CAIE A,203
PUSHJ P,TYPK7
JRST .+2
JRST TYPX
MOVE A,RDTYBF ;CHAR NOT ACCEPTABLE, SO CDR THE RDTYBF
HRR A,(A) ;AND TRY AGAIN
TRNN A,-1
MOVEI A,NIL
MOVEM A,RDTYBF
JUMPN A,TYPK6A
JRST TYPK6B
TYPK7: SKIPL T,(FXP) ;SKIP IF SOUGHT CHAR IS PRESENT IN A
JRST TYPK7A
NW% HLRZ TT,@RSXTB ;SIGN BIT MEANS WE ARE LOOKING FOR RCT TYPE
NW$ MOVE TT,@RSXTB
CAMN T,XC-2 ;-2 => ARG OF T, SO LOOK FOR READ STARTUP CHAR
JRST TYPK7B
CAME T,XC-1 ;-1 => NO ARG, SO ANY NEXT CHAR IS ACCEPTABLE
TDNE TT,T
AOS (P)
POPJ P,
TYPK7A: CAIN A,(T) ;OTHERWISE, LOOKING FOR SPECIFIC CHAR
AOS (P)
POPJ P,
TYPK7B:
NW% TRC TT,4040 ;IN (TYIPEEK T) MODE
NW% TRCE TT,4040
NW$ TLNE TT,(RS.MAC) ;SKIP IF NOT MACRO
NW$ TRNN TT,RS.ALT ;MACRO - SKIP IF SPLICING
JRST TYPK7D
PUSHJ FXP,SAV5M1
HRRZ A,@RSXTB
CALLF 0,(A) ;EXECUTE SPLICING MACRO, AND TRY AGAIN
PUSHJ FXP,RST5M1
POPJ P,
TYPK7D:
NW% TRNE TT,266217 ;CODES TO START OFF A READ
NW$ TDNE TT,[1266217000] ;CODES TO START OFF A READ
AOS (P)
POPJ P,
] ;END OF IFE QIO
IFN QIO,[
TYIPEEK: ;LSUBR (0 . 3) NCALLABLE
SKIPA F,CFIX1
MOVEI F,CPOPJ
MOVEI D,QTYIPEEK
CAMGE T,XC-2
JRST WNALOSE
SKIPE T ;NO ARGS <=> ONE ARG OF NIL
AOJA T,.+2 ;ELSE DECREMENT ARG COUNT FOR INCALL
PUSH P,R70
MOVEI D,(P)
ADDI D,(T)
MOVEI AR2A,CPOPJ
EXCH AR2A,(D)
JSP D,XINCALL ;PROCESS ARGS 2 AND 3
QTYIPEEK ; (ALSO PUSHES F ONTO P)
MOVEI A,Q%TYI
HRLZM A,BFPRDP
MOVEI A,(AR2A) ;GET ARG 1 IN A
JSP T,GTRDTB ;GET READTABLE IN AR2A
JUMPN A,TYPK1 ;NIL => ACCEPT ANY CHAR
PEEK: HRRZ TT,TYIMAN ;CALL TYIMAN ONE EARLY TO
JRST -1(TT) ; SPECIFY PEEKING
TYPK1: CAIE A,TRUTH ;T => SEARCH FOR READER START
JRST TYPK3 ; CHARACTER (E.G. PAREN, MACRO)
TYPK1C: PUSHJ P,PEEK ;PEEK AT A CHAR
JUMPL TT,TYPK9A ;HIT EOF - TAKE A "SOFT" EOF, RETURN -1
MOVE T,@TTSAR(AR2A)
TLC T,4040 .SEE SYNTAX
TLCE T,4040
JRST TYPK1F
CALLF 0,(T) ;HIT A HORRIBLE SPLICING MACRO
JRST TYPK1C ;GO BACK AND TRY AGAIN
TYPK1F: TLNE T,266217 .SEE SYNTAX ;READER START CHARS
POPJ P,
TYPK1H: PUSHJ P,@TYIMAN ;CHAR NOT ACCEPTABLE - GOBBLE IT
JRST TYPK1C ;NOW GO TRY AGAIN
TYPK3: JSP T,FXNV1 ;ARG MUST BE FIXNUM
JUMPL TT,TYPK3C ;ARG BETWEEN 0 AND 777 =>
CAIG TT,777 ; SCAN FOR THAT CHARACTER;
TLOA TT,400000 ; OTHERWISE IS A SYNTAX, LSH'ED
TYPK3C: LSH TT,-11 ; LEFT BY 11, TO SERVE AS MASK
PUSH FXP,TT
TYPK4: PUSHJ P,PEEK ;PEEK AT A CHAR
JUMPL TT,TYPK9 ;SOFT EOF - GO RETURN -1 OR WHATEVER
SKIPL D,(FXP) ;SKIP IF SPECIFIC CHARACTER
JRST TYPK6
CAIN TT,(D) ;COMPARE TO ONE WE GOT
JRST POPXTJ ;SUPER WIN
TYPK5: PUSHJ P,@TYIMAN ;NOT THE ONE - GOBBLE AND RETRY
JRST TYPK4
TYPK6: HLRZ T,@TTSAR(AR2A) .SEE SYNTAX
TDNN T,D ;CHECK SYNTAX AGAINST MASK
JRST TYPK5
JRST POPXTJ
TYPK9: SUB FXP,R70+1
TYPK9A: SKIPN EOFRTN ;"SOFT" EOF. DOES NOT INVOKE
JRST M1TTPJ ; THE EOFFN, BUT WILL PICK UP
JRST EOF9 ; THE EOFVAL IF NECESSARY.
] ;END OF IFN QIO
SUBTTL VALRET AND SUSPEND FUNCTIONS
VALRET: JUMPE T,VLRT9
JSP TT,LWNACK
LA01,,QVALRET
POP P,A
PUSHJ P,VALSTR
IFN ITS,[
SETOM SAWSP
.VALUE MACOUT
SETZM SAWSP
] ;END OF IFN ITS
10$ VLRT9: EXIT 1,
10X WARN [HOW TO EXIT 1, IN TENEX]
POPJ P,
VALSTR: PUSHJ P,PNGET
SETZM MACOUT
MOVE D,[MACOUT,,MACOUT+1]
BLT D,MACOUT+LVLRTS-1
MOVSI D,-LVLRTS+1
VLRT2: HLRZ B,(A)
MOVE TT,(B)
MOVEM TT,MACOUT(D)
HRRZ A,(A)
AOBJP D,VALST0
JUMPN A,VLRT2
MOVE D,MACOUT
CAMN D,[ASCII \:kill\]
JRST .+3
CAME D,[ASCII \:KILL\]
JRST VLRT1
MOVE D,MACOUT+1
CAME D,[ASCII \ \]
CAMN D,[ASCII \
\]
JRST VLRT3
POPJ P,
VLRT1: CAMN D,[ASCII \≠_.\]
JRST VLRT3
CAME D,[ASCII \≠≠U\]
CAMN D,[ASCII \≠≠u\]
10% .LOGOUT
.ELSE XCT VLRT9
POPJ P,
VLRT3:
10$ EXIT
10X WARN [HOW TO EXIT IN TENEX]
IFN ITS,[
.LOGOUT ;TRY TO LOG OUT
JSP T,SIDDTP
.VALUE
.BREAK 16,120000 ;"SILENT KILL"
VLRT9: .LOGOUT ;TRY TO LOG OUT
.VALUE [ASCIZ \:VK \] ;OH, WELL...
POPJ P, ;IN CASE LOSER DOES $P FROM IT
SIDDTP: .SUSET [.ROPTION,,TT]
TLNN TT,10000
JRST (T)
JRST 1(T) ;SKIP IF JOB INFERIOR TO DDT
] ;END OF IFN ITS
SUSPEND: JSP TT,LWNACK
LA01,,QSUSPEND
SETZM MACOUT
JUMPE T,SUSP0
POP P,A
PUSHJ P,VALSTR
SUSP0:
IFE QIO,[
SETZ A,
MOVEI T,SUSCHS
SUSP11: JUMPE T,SUSP12
MOVE B,SUSTBL-1(T)
SKIPN (B)
SOJA T,SUSP11
HLRZS B
PUSHJ P,XCONS
SOJA T,SUSP11
SUSTBL:
QUREAD,,UTIOPD
QUWRITE,,UTOOPD
10% QPRINT,,LPTOPD
IFN MOBIOF,[
IRP X,,[IMX,OMX,IPL,DIS,NVD,BVD]Y,,[IMPX,OMPX,PLOT,DISPLAY,NVFIX,NVID]
Q!Y,,X!OPD
TERMIN
] ;END OF IFN MOBIOF
SUSCHS==.-SUSTBL
] ;END OF IFE QIO
IFN QIO,[
SETZ A,
MOVEI T,LCHNTB
SUSP11: SOJE T,SUSP12
SKIPE B,CHNTB(T)
CAMN B,V%TYI
JRST SUSP11
CAME B,V%TYO
PUSHJ P,XCONS
JRST SUSP11
] ;END OF IFN QIO
SUSP12: JUMPN A,SUSPE
IFN QIO,[
HRRZ A,V%TYI ;CLOSE THE TTYS LAST, SO THEY WONT CAUSE
PUSHJ P,$CLOSE ;SPURIOUS "CANT SUSPEND -I/O IN PROGRESS"
HRRZ A,V%TYO
PUSHJ P,$CLOSE
] ;END OF IFN QIO
SUSP1: HRROS NOQUIT
MOVEM NIL,GCNASV+1
MOVE T,[FREEAC,,GCNASV+2]
BLT T,GCNASV+2+17-FREEAC
SETOM NOPFLS
IFN ITS,[
IFN USELESS*QIO,[
MOVE T,INTMSK
TRNN T,IB<MAR>
JRST SUSP14
.SUSET [.RMARA,,SAVMAR]
.SUSET [.SMARA,,R70]
SUSP14:
] ;END OF IFN USELESS*QIO
.SUSET [.SSNAM,,IUSN]
MOVEI T,SUSP3
EXCH T,LISPSW
MOVEM T,GCNASV
MOVEI T,MACOUT
SKIPN (T)
MOVEI T,[ASCIZ \:≠SUSPENDED≠
\]
SETOM SAWSP
.VALUE (T)
JRST LISPGO
] ;END OF IFN ITS
IFN D10,[
HRRZ T,.JBSA"
HRL T,.JBREN"
MOVEM T,GCNASV
MOVEI T,SUSP3
HRRM T,RETHGH
OUTSTR [ASCIZ \
:$SUSPENDED$
\]
JRST KILHGH
] ;END OF IFN D10
SUSP3:
IFN ITS,[
MOVE T,GCNASV
MOVEM T,LISPSW
JSP T,SHAREP
IFE QIO,[
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
.SUSET [.SMASK,,INTMSK]
] ;END OF IFE QIO
IFN QIO,[
.SUSET [.ROPTION,,TT]
TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
.SUSET [.SOPTION,,TT]
INTON
IFN USELESS,[
MOVE T,INTMSK
TRNE T,IB<MAR>
.SUSET [.SMARA,,SAVMAR]
] ;END OF IFN USELESS
] ;END OF IFN QIO
] ;END OF IFN ITS
IFN D10,[
MOVE T,GCNASV
HRRM T,.JBSA"
HLRM T,.JBREN"
MOVEI T,630000
APRENB T,
GETPPN T,
JFCL
MOVEM T,USN
] ;END OF IFN D10
SETZM NOPFLS
MOVE NIL,GCNASV+1
MOVE T,[GCNASV+2,,FREEAC]
BLT T,17
HRRZS NOQUIT
IFN QIO,[
MOVE TT,IUSN ;IUSN WAS SET UP BY LISPGO
MOVEM TT,TTYIF2+F.SNM
MOVEM TT,TTYOF2+F.SNM
PUSH FXP,TT
PUSHJ P,OPNTTY ;*** TEMP CROCK?
JFCL
PUSH FXP,R70
MOVEI A,-1(FXP)
HRLI A,440600
] ;END OF IFN QIO
IFN ITS*<QIO-1>,[
.SUSET [.RSNAM,,TT]
MOVEM TT,IUSN
MOVEM TT,USN
PUSHJ P,TTYOPN
MOVE A,[440600,,USN]
] ;END OF IFN ITS*<QIO-1>
10% PUSHJ P,READ6C
SA% 10$ PUSHJ P,SUNAME
SA$ SETZ D,
SA$ CALLI D,400071
SA$ PUSHJ P, SUNM2
Q$ SUB FXP,R70+2
MOVEM A,SUDIR
POPJ P,
SUBTTL ARGS FUNCTION
ARGS: JSP TT,LWNACK ;LSUBR (1 . 2) - USES A,B,C,T,TT,D,R,F
LA12,,QARGS
JSP R,PDLA2(T) ;SPREAD ARGS
ARGS1: SKOTT A,SY
JRST ARGS0 ;FIRST ARG MUST BE SYMBOL
HLRZ F,(A)
ARGS1A: AOJL T,ARGS3 ;TWO ARGS
HLRZ R,1(F) ;JUST WANT TO GET PRESENT ARGS PROP
ARGSCU: JUMPE R,FALSE ;ARGS CONS-UP
IDIVI R,1000
SKIPN B,F
JRST ARGSC1
MOVEI TT,-1(F)
JSP T,FIX1A
MOVEI B,(A)
ARGSC1: SKIPN A,R
JRST CONS
MOVEI TT,(R)
CAIE TT,777
SUBI TT,1
JSP T,FIX1A
JRST CONS
ARGS3: JUMPE A,CPOPJ
JUMPN B,ARGS5
HLRZ R,1(F) ;JUST WANT TO FLUSH ARGS PROP
JUMPE R,FALSE
SETZ R,
PUSH P,A
JSP D,ARGCLB
SUB P,R70+1
JRST TRUE
ARGS5: PUSH P,A
SETZB TT,R
HLRZ C,(B) ;MUMBLE MUMBLE - MUST FIGURE
JUMPE C,ARGS6 ; OUT WHATEVER WE WERE HANDED
JSP T,FXNV3
CAIE R,777
ADDI R,1
LSH R,11
ARGS6: HRRZ A,(B)
JSP T,FXNV1
CAIE TT,777
ADDI TT,1
ADDI R,(TT)
HLRZ TT,1(F) ;LOOK AT ARGS PROP ALREADY THERE
CAIN TT,(R) ;IF ALREADY WHAT WE WANT, JUST EXIT,
JRST POPAJ ; THEREBY AVOIDING A PURE PAGE TRAP
MOVEI D,POPAJ ;FAKE OUT A JSP D,
ARGCLB: MOVEI B,(F) ;CLOBBER IN AN ARGS PROPERTY
ARGCL3:
PURTRAP ARGCL7,B, HRLM R,1(B) ;MAY HAVE TO FUSS ABOUT PURE PAGE TRAP
JRST (D)
ARGS0: MOVEI F,$$$NIL
JUMPE A,ARGS1A
WTA [ NON-SYMBOL - ARGS!]
JRST ARGS1
SUBTTL EVALFRAME FUNCTION, GTPDLP, AND FRETURN
EVALFRAME:
SKIPA R,[GTPDLP] ;THIS ENTRY CAUSES INTERPRETATION OF ARG AS PDLPOINTER
FRM2A: MOVEI R,GTPDL2 ;THIS ENTRY, TO ALLOW CONTINUING FROM WHERE D CURRENTLY IS
JSP R,(R)
$EVALFRAME ;GET EVALFRAME OR APPLYFRAME JUST PRIOR TO
$APPLYFRAME ; POINT ON PDL MARKED BY ARG
JRST FALSE
FRM3: SUB D,R70+1 ;DEFINE A FRAME POINTER TO BE JUST BELOW THE EVALFRAME MARKER
HRRZ TT,(D)
JUMPN F,FRM3A ;F IS INDEX OF WHICH KIND OF FRAME
MOVEI T,(TT)
LSH T,-SEGLOG
SKIPL ST(T)
JRST FRM4A
HLRZ TT,(TT)
FRM3A: CAIN TT,QEVALFRAME ;DONT ALLOW THE CALL TO EVALFRAME
JRST FRM2B ; ITSELF TO BE OUTPUT
FRM4A: PUSH P,(D)
FRM4: ;ERRFRAME COMES HERE
HLRO TT,(D) ;ONE LEFT HALF'S AS GOOD AS ANOTHER...
JSP T,FIX1A ;MAKE UP PREVIOUS SPECIAL PDL POINTER
PUSHJ P,ACONS
EXCH B,(P)
MOVE TT,1(D)
CAME TT,[$APPLYFRAME]
JRST FRM8
PUSH P,A
PUSH P,B
MOVE T,-2(D) .SEE $APPLYFRAME ;BECAUSE THERE IS A DISCUSSION
JUMPL T,FRM5 ; OF THE FRAME FORMAT THERE
MOVEI A,(T)
TLCN T,-1 ;THINK ABOUT THIS WHEN YOU LOOK!
JRST FRM7
HLRS T ;SUBTLE WAY TO GET NEGATION
ADDI T,(D)
FRM5: SETZ A,
FRM5A: HRRZ B,(T)
PUSHJ P,XCONS
AOBJN T,FRM5A
PUSHJ P,NREVERSE
FRM7: PUSHJ P,ACONS
POP P,B
PUSHJ P,XCONS
MOVEI B,(A)
POP P,A
FRM8: PUSHJ P,XCONS
MOVE B,A ;OUTPUT 4-LIST: "EVAL" OR "APPLY" OR "ERR" [A SYMBOL]
HRROI TT,(D) ; FRAME (REGPDL) POINTER [A FIXNUM]
JSP T,FIX1A ; <FORM> [EVAL] OR (<FN> <ARGS>) [APPLY]
PUSHJ P,CONS ; OR <MSG-FORM> [ERR]
MOVE TT,1(D) ; ALIST (SPECPDL) POINTER [A FIXNUM]
MOVEI B,QOEVAL
CAMN TT,[$APPLYFRAME]
MOVEI B,QAPPLY
CAMN TT,[$ERRFRAME]
MOVEI B,QERR
PUSHJ P,XCONS
JRST POPBJ
FRM2B: TLNE R,1
ADD D,R70+2 ;WHEN SEARCHING FORWARD, SKIP OVER CALL
JRST FRM2A ;TO EVALFRAME
GTPDLP: ;CALLED BY JSP R,GTPDLP; RETURNS PDL PTR IN D
MOVEI D,(P)
JUMPE A,GTPDL2 ;ARG=NIL => START SEARCH FROM CURRENT PDL POS
JSP T,FXNV1 ;NOTE: EVALFRAME LOOKS AT BIT 3.1 OF R
JUMPL TT,GTPDL5 ;BIT 3.1 OF R = 0 WHEN SEARCHING BACK THE PDL
TLO R,1 ;BIT 3.1 OF R = 1 WHEN SEARCHING FORWARD
MOVNS TT ;WANT TO SKIP OVER THE FRAME MARKER WHEN
SKIPN TT ; SEARCHING FORWARD (SINCE A PDLPOINTER WILL
SKIPA TT,C2 ; BE POINTING TO ONE BELOW A FRAME MARKER)
ADD TT,R70+2
GTPDL5: TLZ TT,-1
HRRZ T,C2
CAIGE TT,(T)
JRST GTPDL1
MOVEI T,(P)
SUBI T,(TT)
JUMPLE T,GTPDL1
MOVEI T,(TT)
CAIL T,(P)
MOVE TT,P
HRROI D,(TT)
GTPDL2: MOVE TT,(R) ;KEY ON WHICH TO SEARCH
JUMPE TT,2(R) ;MATCH 0 => NO SEARCH, JUST GIVE OUT PDL PTR
MOVE F,1(R) ;WELL, IT'S POSSIBLE TO SEARCH FOR TWO THINGS
TLNE R,1
JRST GTPDL4
HRRZ T,C2
GTPDL3: CAIL T,(D) ;A BACK SEARCH
JRST 2(R) ;SEARCHED-AND-FAILED EXIT
CAMN TT,(D)
JRST GTPX0
CAMN F,(D)
JRST GTPX1
SOJA D,GTPDL3
GTPDL4: MOVEI T,(P)
GTP4A: CAMN TT,(D)
JRST GTPX0
CAMN F,(D)
JRST GTPX1
CAIG T,(D)
JRST 2(R) ;FAILURE
AOJA D,GTP4A
GTPX0: TDZA F,F
GTPX1: MOVEI F,1
JRST 3(R)
FRETURN: MOVE C,B
JSP R,GTPDLP
0
JFCL
MOVEI F,(D)
MOVE TT,[$EVALFRAME]
CAMN TT,1(F)
JRST FRETR1
MOVE TT,[$APPLYFRAME]
CAME TT,1(F)
JRST FRERR
FRETR1: MOVEI D,(F)
SUBI D,(P)
HRLI D,(D)
HRRI D,(F)
MOVE TT,[$UIFRAME]
CAME TT,(D) ;SEARCH FOR A USER INTERRUPT FRAME
AOBJN D,.-1
CAMN TT,(D)
JSP TT,UIBRK
FRP1: SKIPE T,PA4 ;BREAK UP A DOMINEERING PROG
CAIL F,(T) ;[WHICH BREAKS UP INTERIOR ERRSETS AND CATCHES]
JRST FRP2
MOVEI TT,FRP1-1 ;FAKE OUT RETURN BY INSERTING A RETURN-ADDRESS
MOVEM TT,-LPRP+1(T) ;OF FRP1 ON THE PDL
JRST RETURN
FRP2: SKIPN B,ERRTN ;BREAK UP A DOMINEERING ERRSET OR CATCH
SKIPE B,CATRTN
FRP2A: CAIL F,(B)
JRST FRP3
MOVEI TT,FRP1
JRST BKRST0
FRP3: SKIPN B,EOFRTN ;BREAK OUT OF ANY E-O-F SET READS
JRST FRP3QA
CAIGE F,(B)
JRST FRP2A
FRP3QA: MOVE A,C
HRROI P,1(F) ;SEE ABOVE FOR WHY LH IS -1
HLRO FLP,-2(P)
HRRO FXP,-2(P)
HLRZ TT,-1(P)
JRST UBD ;UNBIND TO MARKED POINT, AND POP FRAME
SUBTTL GETCHAR, GETCHARN, AND SUBLIS
$GETCHARN: PUSH P,CFIX1 ;SUBR 2 - NCALLABLE
SKIPA F,[ZPOPJ,,CPOPJ]
GETCHAR: MOVE F,[FALSE,,RDCH2] ;SUBR 2
SKIPE V.RSET
JRST GETCH8
MOVE D,(B)
PUSHJ P,PNGT0
GETCH1: SOJL D,(F)
IDIVI D,5 ;(Q,R) QUOTIENT,REMAINDER IN D,R
SOJL D,GETCH3
GETCH2: HRRZ A,(A) ;CDR BY Q WORDS
SOJGE D,GETCH2 ;RECALL THAT (CDR NIL) = NIL
JUMPE A,GETCH4
GETCH3: HLRZ A,(A)
LDB TT,GTCTB(R)
JUMPN TT,(F)
GETCH4: MOVS F,F
JRST (F)
GETCH8: JSP T,FXNV2
PUSHJ P,PNGET
JRST GETCH1
GTCTB: 350700,,(A)
260700,,(A)
170700,,(A)
100700,,(A)
010700,,(A)
SUBLIS: PUSH P,A ;USES ONLY A,B,T,TT,D,R
PUSH P,B
MOVE D,A
HLLOS NOQUIT ;MOBY DELAYED QUIT FEATURE
SUBL1: JUMPE D,SUBL2
HLRZ T,(D) ;A SUBSTITUTION LIST IS LIKE
HLRZ B,(T) ;((U1 . S1) (U2 . S2) . . .)
SKOTT B,SY
JRST SUBLOSE
SUBL1B: HRRZ A,(B) ;SEXPRESSION S IS SUBSTITUTED FOR ATOM U
HLRZ A,(A)
CAIN A,QSUBLIS
JRST SUBL1A
HRRZ A,(T)
MOVEM B,T
HRRZ B,(B)
PUSHJ P,CONS
MOVEI B,QSUBLIS ;PUT "SUBLIS" PROPERTY ONTO THOSE ATOMS U IN THE
PUSHJ P,XCONS ;SUBSTITUTION LIST ((U1 . V1) . . . (UN . VN))
HRRM A,(T)
SUBL1A: HRRZ D,(D)
MOVE T,INTFLG
AOJGE T,SUBL1 ;0=> NO INT, -1=> USER INT, -2,-3=> QUIT
MOVE R,D
JRST SUBL3Q
SUBLOSE: JUMPE B,SUBL3Z
MOVEI A,(B)
MOVEI R,(D)
MOVEI T,[LER3 [SIXBIT \NON-ATOMIC ITEM - SUBLIS!\]]
MOVEM T,-1(P)
SUBL3Q: SUB P,R70+1
JRST SUBL3A
SUBL3Z: MOVEI B,NILPROPS
JRST SUBL1B
SUBL2: POP P,A
PUSHJ P,SBL1
JFCL
MOVEI R,0 ;REMOVE ALL "SUBLIS" PROPERTIES
SUBL3A: MOVE TT,(P)
SUBL3: CAIN R,(TT) ;REMOVE "SUBLIS" PROPERTY
JRST SUBL4
HLRZ T,(TT)
HLRZ T,(T)
JUMPN T,.+2
MOVEI T,NILPROPS
HRRZ B,(T)
MOVE B,(B)
HLRZ D,B
HRRZ B,(B)
CAIN D,QSUBLIS
HRRM B,(T)
HRRZ TT,(TT)
JRST SUBL3
SUBL4: SUB P,R70+1
JRST CZECHI
SBL1: SKOTT A,LS ;TRACE THROUGH STRUCTURE IN (A) SUBSTITUTING
JRST SBL2 ;(GET 'U 'SUBLIS) FOR U WHEREVER IT IS NON-NIL
PUSH P,A
HLRZ A,(A)
PUSHJ P,SBL1
JRST SBL4
EXCH A,(P)
HRRZ A,(A)
PUSHJ P,SBL1
JFCL
HRRZ B,(P)
SBL5: SUB P,R70+1
PUSHJ P,XCONS
JRST POPJ1
SBL4: HRRZ A,@(P)
PUSHJ P,SBL1
JRST POPAJ
HLRZ B,@(P)
JRST SBL5
SBL2: TLNN TT,SY
JRST SBL2B
HRRZ B,(A)
SBL2A: HLRZ T,(B)
CAIE T,QSUBLIS
POPJ P,
HRRZ A,(B)
HLRZ A,(A)
JRST POPJ1
SBL2B: JUMPN A,CPOPJ
HRRZ B,NILPROPS
JRST SBL2A
SUBTTL SAMEPNAMEP AND ALPHALESSP
SAMEPNAMEP: TDZA D,D ;USES ONLY A,B,T,TT,D
ALPHALESSP: MOVEI D,TRUTH ;MUST PRESERVE C,AR1,AR2A,R,F (SEE SORT)
PUSH P,B
PUSHJ P,PNGET
EXCH A,(P)
PUSHJ P,PNGET
POP P,B ;FROM NOW ON, A HAS PNAME OF 2ND ARG, B OF 1ST!!!
JRST ALPLP1
ALPL3: HRRZ A,(A)
HRRZ B,(B)
ALPLP1: JUMPE B,ALPL2
JUMPE A,FALSE ;ON SAMEPN, LOSE IF 2ND ARG RUNS OUT BEFORE 1ST
HLRZ T,(A) ;ON ALPHAL, LOSE IF 2ND ARG IS SHORTER THAN 1ST
MOVE T,(T)
HLRZ TT,(B) ;FOR SAMEPN, WILL RETURN NIL IF TWO ARE UNEQUAL IN SOME PLACE
CAMN T,(TT) ;NO INFO IF CORRESPONDING PLACES ARE EQUAL
JRST ALPL3
JUMPE D,FALSE ;BUT NOT EQUAL IN SAMENAMEP MEANS LOSE
MOVE TT,(TT) ;MUST DO SOME HAIR FOR THE ALPHALESSP
LSHC T,-1 ; COMPARE TO WIN, SINCE PNAME WORDS ARE
CAMG T,TT ; LOGICAL DATA, NOT ARITHMETIC
JRST FALSE ;2ND ARG STRICTLY LESS THAN FIRST
JRST TRUE ;2ND ARG STRICTLY GREATER THAN FIRST
ALPL2: EXCH A,D
JUMPE D,NOT ;IF ALPHAL, WIN WHEN A NON-NUL [FOR 1ST ARG IS PROPER SUBSTRING OF 2ND]
POPJ P, ;IF SAMEPN, WIN WHEN A NUL [FOR CORRESPONDENTS HAVE BEEN EQUAL ALL ALONG]
SYSP: MOVEI B,TRUTH ;SUBR 1 - DETERMINE WHETHER SYMBOL HAS
SYSP3:
10% CAIGE A,BEGFUN ; A "SYSTEM" SUBR PROPERTY
10$ CAIL A,ENDFUN
JRST FALSE
10% CAIG A,ENDFUN
10$ CAIL A,BEGFUN
JRST BRETJ
CAIGE A,BSYSAR ; ... OR MAYBE A SYSTEM ARRAY PROPERTY
JRST SYSP6
CAIGE A,ESYSAR
JRST BRETJ ;RETURNS T FOR SUBR/SAR POINTERS
CAIE B,QAUTOLOAD
JRST SYSP6
CAIL A,BSYSAP
CAIL A,ESYSAP
JRST FALSE
JRST BRETJ
SYSP6: JSP T,SPATOM ;RETURNS FALSE FOR NON-SYMBOLS
JRST FALSE
MOVEI B,ASBRL
PUSHJ P,GETL1
JUMPE A,CPOPJ ;RETURNS FALSE FOR SYMBOLS WITH NO FN PROPS
HLRZ B,(A) ;RETURNS NAME OF PROPERTY OF ONE IS FOUND,
JSP T,%CADR
JRST SYSP3 ; AND THE PROPERTY VALUE PASSES THE SYSP TEST
GCTWA: JUMPE A,GCTWI
HLRZ A,(A)
PUSHJ P,NOTNOT
MOVEM A,VGCTWA
JRST GCTWX
GCTWI: SETOM IRMVF
GCTWX: MOVEI A,IN0
SKIPGE IRMVF
ADDI A,1
SKIPE VGCTWA
ADDI A,10
POPJ P,
SUBTTL COPYSYMBOL FUNCTION
COPYSYMBOL: JUMPE A,CPOPJ
JSP T,SPATOM
JSP T,PNGE
JUMPN B,CPSY0
CPSY: PUSHJ P,PNGT0
JRST SYCONS
CPSY0: PUSH P,A
PUSHJ P,CPSY
EXCH A,(P)
PUSH P,A
HRRZ A,(A)
JUMPE A,S1PAJ
MOVEI B,NIL
PUSHJ FXP,SAV5M3
PUSHJ P,.APPEND
PUSHJ FXP,RST5M3
HRRM A,@-1(P)
HLRZ A,@(P)
HLRZ T,1(A) ;ARGS PROPERTY
JUMPE T,.+3
HLRZ TT,@-1(P)
HRLM T,1(TT)
HRRZ A,@(A)
CAIN A,QUNBOUND
JRST S1PAJ
EXCH AR1,-1(P)
JSP T,.SET
EXCH AR1,-1(P)
JRST S1PAJ
SUBTTL SETSYNTAX AND OTHER READER SYNTAX FUNCTIONS
;ARGS ARE CHAR (AS NUMBER OR ATOM), SYNTAX-CODE, MACRO-OR-TRANSLATION
SETSYNTAX: SETZ AR1, ;SUBR 3
MOVEI AR2A,(B)
JSP T,SPATOM
JRST RSSYN1
JSP T,CHNV1
JSP T,FIX1A
RSSYN1: CAIN AR2A,QMACRO
JRST RSSYN2
CAIE AR2A,QSPLICING
JRST RSSYN3
MOVEI AR1,[QSPLICING,,NIL]
RSSYN2: MOVE B,A
PUSH P,CTRUE
PUSH P,AR1
JRST SSMC43
RSSYN3: MOVSI AR1,40000 ;WAY TO FAKE OUT SSYN0
MOVEI B,(A)
JUMPE C,RSSYN5 ;SKIP IF NO CHTRAN STUFF
PUSHJ P,RSSYN4
HRRZM A,(FXP)
IFN NSTAT,[
MOVEI A,(B) ;LOSING RETROFIT
MOVEI B,(C)
] ;END OF IFN NSTAT
PUSHJ P,SSCHTRAN
SUB FXP,R70+1
RSSYN5: JUMPE AR2A,TRUE ;XIT IF NO SYNTAX STUFF
CAIE AR2A,QSINGLE
JRST RSSYN7
NW% PUSH FXP,[600500]
NW$ PUSH FXP,[RS.SCS]
MOVEI C,(FXP)
JRST RSSYN8
RSSYN7: MOVE C,AR2A
PUSHJ P,RSSYN4
HLRZS (FXP)
RSSYN8:
IFN NSTAT,[
MOVEI A,(B) ;LOSING RETROFIT
MOVEI B,(C)
] ;END OF IFN NSTAT
PUSHJ P,SSSYNTAX
SUB FXP,R70+1
CTRUE: JRST TRUE
RSSYN4: PUSH FXP,R70
MOVEI A,(C)
JSP T,SPATOM
POPJ P,
MOVEI C,(B) ;SAVE B
JSP T,CHNV1
MOVEI A,(TT)
MOVEI B,(C) ;RESTORE B
MOVEI C,(FXP) ;SET C TO BE FIXNUM ON TOP OF PDL
JSP T,RSXST
MOVE TT,@RSXTB
MOVEM TT,(FXP)
POPJ P,
SSCHTRAN:
NW% SKIPA F,[HRRM R,(TT)]
NW$ SKIPA F,[DPB R,[001100+TT,,]]
SSSYNTAX:
NW% MOVSI F,(HRLM R,(TT))
NW$ MOVE F,[LDB R,[113300+TT,,]]
PUSH P,[SPROG3]
MOVSI AR1,40000 ;LOSING CROCK
SSSYN1:
IFN NSTAT, MOVEI C,(B) ;LOSING CROCK
IFN NSTAT, MOVEI B,(A)
PUSHJ P,GRCTI ;GET INDEX FOR RCT INTO D
TLNE AR1,40000 ;40000 BIT SAYS EVAL 3RD ARG
JSP T,FXNV3
JSP T,SMCR2 ;LOCK AND SETUP RCT ARRAY PTR INTO TT
ADDI TT,(D)
XCT F ;MAY SKIP (FOR (STATUS CHTRAN))
UNLKPOPJ ;MUST BE ONLY ONE INSTRUCTION.
NW% TLNE TT,4000 ;SKIP UNLESS MACRO CHAR
NW$ TLNE TT,(RS.MAC);SKIP UNLESS MACRO CHAR
MOVEI TT,(D) ;USE CHARACTER AS ITS OWN CHTRAN
TLZ TT,-1
UNLKPOPJ
GRCTI: JSP T,FXNV2 ;GET READTABLE INDEX
CAIGE D,NASCII
JUMPGE D,CPOPJ
JRST GRCTIE
SMACRO:
IFN NSTAT, MOVEI B,(A)
PUSHJ P,GRCTI
JSP T,SMCR2
ADD TT,D
SMCR1: MOVEI A,NIL
MOVE C,(TT)
UNLOCKI
NW% TLNN C,4000
NW$ TLNN C,(RS.MAC)
POPJ P, ;EXIT WITH NIL IF NO MACRO CHAR
NW% TLNE C,40
NW$ TRNE C,RS.ALT
MOVEI A,QSPLICING ;SPLICING TYPE
PUSHJ P,NCONS
NW% MOVEI B,(C)
NW$ PUSH P, A
NW$ PUSHJ P, GETMAC
NW$ HRRZ B, (A) ;CDR OF ASSQ IS FUNCTION
NW$ POP P, A
PUSHJ P,XCONS
POPJ P,
IFN NEWRD,[
;;;ROUTINE TO GET MACRO ENTRY. CHAR IN D.
;;; CLOBBERS A, B, TT, RETURNS (CHAR . FCN) IN A
;;; RSXST MUST HAVE BEEN DONE
GETMAC: MOVEI A, 206 ;GET FCN LIST FROM READTABLE
HRRZ B, @RSXTB ;..
MOVE A, D ;CHARACTER
PUSHJ P, ASSQ
JUMPE A, [LERR [SIXBIT/MACRO CHARACTER VANISHED#!!/]]
POPJ P,
] ;END OF IFN NEWRD
SSMACRO:
IFN NSTAT,[
CAME T,XC-3 ;CROCK TO GET NSTAT UP FAST
PUSH P,R70
POP P,A
POP P,C
POP P,B
SKIPE A
PUSHJ P,ACONS
PUSH P,A
] ;END OF IFN NSTAT
SSMC43: PUSHJ P,GRCTI
JSP T,SMCR2
ADD TT,D
HRRZM TT,RM4
JUMPE C,SSM1
NW% HRLI C,404500
NW$ MOVE C,[RS.CMS]
SKIPE A,(P)
JRST SSM3
SSM4:
EXCH C,@RM4
NW% HRRZ A,C
NW% TLNE C,4000
NW% PUSHJ P,SSGCREL ;CLOBBERS C
IFN NEWRD,[
TLNN C,(RS.MAC)
JRST SSM4AA
PUSHJ P, GETMAC
;REMOVE PREVIOUS MACRO FUNCTION FROM ASSQ LIST.
;**** (SETQ MAC-LIST (DELQ A MAC-LIST)) ****
SSM4AA: ;AND NO GCREL CRUFT NECC.
]
MOVE C,@RM4
NW% HRRZ A,C
NW% TLNE C,4000
NW% PUSHJ P,SSGCPRO
NW% HRRM A,@RM4
NW$ DPB D, [001100,,@RM4] ;MACROS MUST HAVE SELF AS CHTRAN
NW$ MOVE B, D ;***SURELY THIS COULD BE A LOT LESS KLUDGEY***
NW$ PUSHJ P, XCONS
NW$ MOVE B, A
NW$ MOVEI A, 206
NW$ MOVE A, @RSXTB
NW$ PUSHJ P, XCONS
NW$ MOVE B, A
NW$ MOVEI A, 206
NW$ MOVEM B, @RSXTB
SUB P,R70+1
MOVE TT,RM4
JRST SMCR1
SSM3: MOVEI AR1,(B)
HLRZ A,(A)
JSP T,CHNV1
CAIN TT,"S ;SPLICINGP
NW% TLO C,40
NW$ TRO C,RS.ALT
MOVEI B,(AR1)
JRST SSM4
SMCR2: LOCKI
JRST RSXST
SSM1: HRLI D,2
MOVE C,RCT0(D)
NW% TLNE C,4000 ;WAS IT ORIGINALLY A MACRO CHAR?
NW$ TLNE C,(RS.MAC)
MOVE C,D
JRST SSM4
SSGCREL: TDZA D,D ;MUST HAVE USER INTERRUPTS OFF
SSGCPRO: MOVEI D,1
JSP T,SPATOM
JRST .+2
POPJ P,
SAVE A B
HRRZ R,(B)
CAIGE R,200
HRL R,VREADTABLE
HRRI R,IN0(R)
MOVE B,PROLIS
JUMPE D,SSGRL1
PUSHJ P,ASSOC
JUMPE A,SSPROQ
HLRZ A,(A)
MOVEM A,-1(P)
SSPROQ: MOVE B,R
PUSHJ P,CONS1
MOVE B,-1(P)
PUSHJ P,XCONS
MOVE B,PROLIS
PUSHJ P,CONS
MOVEM A,PROLIS
MOVE A,-1(P)
SSPROX: POP P,B
JRST POP1J
SSGRL2: MOVE A,-1(P)
SSGRL1: PUSHJ P,ASSQ
JUMPE A,SSPROX
HRRZ B,(B)
HRRZ T,(A)
CAME R,(T) ;COMPARES READTABLE AND NUMBER
JRST SSGRL2
MOVE B,PROLIS
PUSHJ P,.DELETE
MOVEM A,PROLIS
MOVEI A,0
JRST SSPROX
IFE QIO,[
SUBTTL IOC AND IOG FUNCTIONS
IOC: JUMPE A,CPOPJ ;FSUBR
HRROI R,IOC1
PUSHJ P,PRINTA
JRST TRUE
IOC1: CAIL A,"@ ;100
CAILE A,"↑ ;136
POPJ P,
SETZM IPCLOK
PUSHJ P,UINTPU
ANDCMI A,100
JSR CNTROL
IOC2: JRST UINTEX
IOG: PUSHJ P,IOGBND ;FSUBR
HRRZ B,(A)
HLRZ A,(A)
PUSH P,B
SKIPE A
PUSHJ P,IOC
POP P,B
PUSHJ P,IPROGN
JRST UNBIND
] ;END OF IFE QIO
AUTOLOAD: HRL A,T
PUSHJ P,ACONS
MOVSS (A)
PUSH P,A ;FOR GC PROTECTION
IFE QIO,[
HRLI A,18. ;INTERRUPT NO. FOR AUTOLOAD FUN
MOVSS A
PUSHJ P,UINT
] ;END OF IFE QIO
IFN QIO,[
PUSH FXP,D
MOVSI D,(A)
HRRI D,1000 ;AUTOLOAD USER INTERRUPT
PUSHJ P,UINT
POP FXP,D
] ;END OF IFN QIO
JRST POP1J
IFN ITS,[
SUBTTL SYSCALL FUNCTION
SYSCALL: MOVEI D,QSYSCALL
CAML T,[-10.]
CAMLE T,XC-2
JRST WNALOSE
MOVEI D,2(P)
ADD D,T ;D POINTS TO ARG WITH .CALL NAME IN IT
MOVNM T,SYSCL8 ;#ARGS+2
JSP T,0PUSH+2(T) ;PUSH SLOTS FOR COPYING FIXNUM ARGS
SCSL0: MOVE A,-1(D)
JSP T,FXNV1 ;<CONTROL-BITS>,,<NUMBER-OF-OUTPUTS-DESIRED>
HLL D,TT
HRRZS TT
CAILE TT,20
JRST SCSTMA
HRLM TT,SYSCL8 ;#ANSWERS,,#ARGS+2
MOVE A,(D)
PUSH FXP,D
PUSHJ P,SIXMAK
MOVSI D,(SETZ)
EXCH D,(FXP) ;THE SETZ GETS PUT OUT HERE
MOVEI R,-1(FXP)
MOVEI F,(FXP)
PUSH FXP,TT ;THE SIXBIT FOR THE NAME OF THE .CALL
HLRZ T,D
TLZ D,-1
TLO T,5000 ;THE CONTROL BITS ARG
JRST SCSL1A
SCSL1: HRRZ T,(D)
SKOTT T,FX
JRST SCSL1A
MOVE TT,(T)
MOVEM TT,(R)
MOVEI T,(R)
SUBI R,1
SCSL1A: PUSH FXP,T
IFN QIO,[
MOVEI AR1,(T)
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
MOVE T,R ;DOUBLE FOO - JONL!!
JSP TT,XFILEP
JRST SCSL6
MOVE TT,[@TTSAR]
ADDM TT,(FXP)
SCSL6: MOVE R,T
] ;END OF IFN QIO
CAIGE D,(P) ;LOOP TO INSTALL REMAINING INPUT ARGS
AOJA D,SCSL1
HLRZ D,SYSCL8
SOJL D,SCSL4
MOVEI T,1(FXP)
HRLI T,2000
SCSL3: PUSH FXP,T ;LOOP TO INSTALL ANSWER REQUESTS
ADDI T,1
SOJGE D,SCSL3
SCSL4: MOVSI T,(SETZ) ;FINAL SETZ SIGNALS END OF PARAMETERS
IORM T,(FXP) ;[THERE WILL ALWAYS BE AT LEAST ONE, I.E. THE CONTROL]
Q$ MOVEI TT,F.CHAN
.CALL (F)
JRST SCSFAI
SETZB A,B
HLRZ D,SYSCL8
SCSL5: JUMPE D,SCSXIT ;LOOP TO LISTIFY UP NUMERIC ANSWERS
POP FXP,TT
PUSHJ P,CONSFX
SOJA D,SCSL5
SCSTMA: MOVEI TT,15
JRST SCSXT1
SCSFAI: .SUSET [.RBCHN,,R]
.CALL SCSTAT
.VALUE
LDB TT,[220600,,D]
MOVE D,SYSCL8
HLRS D
SUB FXP,D ;TAKE OFF THE SLOTS FOR ANSWERS
JSP T,FXCONS ;LISP NUMBER FOR ERROR CODE
SCSXIT: MOVE D,SYSCL8 ;SYSCL8 HAS 2+#ARGS
ADDI D,-1(D) ;PUSHED WAS 3+2*#ARGS
HRLS D ; WHICH IS 2*SYSCL8-1
SUB FXP,D
SCSXT1: MOVE D,SYSCL8
HRLS D
SUB P,D ;STRAIGHTEN UP P
POPJ P,
SCSTAT: SETZ
SIXBIT \STATUS\ ;GET CHANNEL STATUS
,,R ;CHANNEL #
402000,,D ;STATUS WORD
.SEE IOCERR
.SEE CHNI1
] ;END OF IFN ITS
$INSRT STATUS ;HAIRY STATUS FUNCTIONS
SUBTTL CURSORPOS FUNCTION
IFN USELESS*ITS,[
IFE QIO,[
CURSORPOS: JSP TT,LWNACK ;LSUBR (0 . 2) - HACK CURSOR
LA012,,QCURSORPOS ; FOR CHARACTER DISPLAYS
JSP R,PDLA2(T)
SKIPN TTYOFF ;↑W DISABLES, OF COURSE
SKIPN TTYDISP ;USELESS ON PRINTING TERMINALS
JRST FALSE
JUMPE T,CRSRP1 ;0 ARGS - GET POSITION
AOJE T,CRSRP3 ;1 ARG - SPECIAL HACKS (↑P CODES)
PUSH P,B ;2 ARGS - SET POSITION (↑P H, ↑P V)
MOVSI R,(ASCII \⊂V\) ;SET VERTICAL POSITION
PUSHJ P,CRSRP5
MOVSI R,(ASCII \⊂H\) ;SET HORIZONTAL POSITION
POP P,A
CRSRP5: JUMPE A,TRUE ;NIL MEANS NO CHANGE
JSP T,FXNV1
SKIPGE TT
SETZ TT,
CAILE TT,167 ;NOR ARG ABOVE 167
MOVEI TT,167
ADDI TT,10 ;ADD 10 FOR ↑P CROCK
DPB TT,[170700,,R]
CRSRP7: MOVEI D,R
PUSHJ P,SRNTYP ;SHOVE OUT ↑P COMMAND
JRST TRUE
CRSRP3: JSP T,SPATOM ;IF SYMBOL, USE FIRST CHAR
JRST CRSRP4
JSP T,CHNV1
JRST CRSRP6
CRSRP4: JSP T,FXNV1 ;ELSE BETTER BE FIXNUM
CRSRP6: MOVEI R,(TT)
TRC TT,100
TDNE TT,[-40]
JRST CRSRP2
MOVE TT,GCBT(TT)
TDNN TT,CRSRP9
JRST CRSRP2
LSH R,26 ;IF LEGAL, PUT A ↑P IN FRONT
TLO R,<↑P>←13 ; AND HAND IT OFF TO SRNTYP
MOVEI D,R
JRST CRSRP7
CRSRP9:
ZZZ==100 ;[CODE FOR "↑P ]" (BEWARE BRACKETS)
IRPC X,,[ABCDEFKLMNPTUXZ]
ZZZ==ZZZ\<SETZ←-<"X&37>>
TERMIN
ZZZ ;BITS SPECIFYING VALID ↑P CODES
EXPUNGE ZZZ ;NOTE: H AND V NOT VALID HERE!
CRSRP1: .CALL RCPSBK ;GET CURRENT CURSOR POSITION
.VALUE
MOVEI TT,(D) ;CONS THEM UP FOR LOSER
JSP T,FIX1A
MOVEI B,(A)
HLRZ TT,D
JSP T,FIX1A
JRST CONS
] ;END OF IFE QIO
;;; IFN USELESS*ITS
IFN QIO,[
CURSORPOS: MOVEI D,QCURSORPOS ;LSUBR (0 . 3)
CAMGE T,XC-3 ;MORE THAN THREE ARGS LOSES
JRST WNALOSE
JUMPE T,CRSRP0 ;IF NO ARGS, IS FOR DEFAULT TTY
CRSRPS: SKIPN AR1,(P) ;ELSE LAST ARG MAY BE TTY FILE ARRAY
JRST CRSRN
MOVEI TT,(AR1)
LSH TT,-SEGLOG
SKIPGE ST(TT)
JRST CRSRMP
CAIN AR1,TRUTH ;LAST ARG = T
HRRZ AR1,V%TYO ; MEANS THE DEFAULT TTY
CRSR10: CAMN T,XC-3 ;FOR THREE ARGS MUST HAVE A FILE ARRAY
JRST CRSRP8
JSP TT,XFILEP ;FOR ONE OR TWO ARGS MAY OR MAY
JRST CRSRP0 ; NOT HAVE A FILE ARRAY
CRSRP8: SUB P,R70+1 ;IF WE HAVE ONE, IT MUST
PUSH FXP,T ; BE A BONA FIDE TTY OUTPUT FILE
PUSHJ P,TOFLOK
UNLOCKI
POP FXP,T
AOSA T
CRSRP0: HRRO AR1,V%TYO
JSP R,PDLA2(T)
MOVEI TT,F.MODE
MOVE D,@TTSAR(AR1)
SKIPGE AR1 ;IF FILE NOT EXPLICITLY GIVEN
SKIPN TTYOFF ; THEN ↑W NON-NIL => RETURN NIL
TLNN D,FBT<CP> ;RETURN NIL IF NOT DISPLAY
JRST FALSE
JUMPE T,CRSRP1 ;0 ARGS - GET POSITION
AOJE T,CRSRP3 ;1 ARG - SPECIAL HACKS (↑P CODES)
SKOTT A,FX ;2 ARGS
JRST CRSR11
MOVEI D,"V ;SET VERTICAL POSITION
PUSHJ P,CRSRP5
CRSR20: MOVEI D,"H ;SET HORIZONTAL POSITION
MOVEI A,(B)
CRSRP5: JUMPE A,TRUE ;NIL MEANS NO CHANGE
JSP T,FXNV1
SKIPGE TT
SETZ TT, ;NEGATIVE ARG NOT ALLOWED
CAILE TT,167 ;NOR ARG ABOVE 167
MOVEI TT,167
HRLI D,10(TT) ;ADD MAGIC 10 TO AMOUNT FOR ↑P
CRSRP7: PUSHJ P,CNPCOD
JRST TRUE
CRSRP3: JSP T,SPATOM ;IF SYMBOL, USE FIRST CHAR
JRST CRSRP4
PUSHJ P,CRSR40
JRST CRSRP6
CRSR40: JSP T,CHNV1
CAIL TT,140
SUBI TT,40 ;CONVERT TO UPPER CASE
POPJ P,
CRSRP4: JSP T,FXNV1 ;ELSE BETTER BE FIXNUM
CRSRP6: MOVEI D,(TT)
TRC TT,100
TDNE TT,[-40]
JRST CRSRP2
MOVE TT,GCBT(TT)
TDNN TT,CRSRP9
JRST CRSRP2
JRST CRSRP7
CRSRP9:
ZZZ==100 ;[CODE FOR "↑P ]" (BEWARE BRACKETS)
IRPC X,,[ABCDEFKLMNTUXZ]
ZZZ==ZZZ\<SETZ←-<"X&37>>
TERMIN
ZZZ ;BITS SPECIFYING VALID ↑P CODES
EXPUNGE ZZZ ;NOTE: H AND V NOT VALID HERE!
CRSR11: JUMPE A,CRSR20
JSP T,SPATOM
JRST CRSR12
PUSHJ P,CRSR40
JSP T,FXNV2
SKIPGE D
SETZ D,
CAIE TT,"H
CAIN TT,"V
JRST CRSR13
CAIN TT,"I
JRST CRSR14
CRSR12: WTA [BAD CURSOR CODE - CURSORPOS!]
JRST CRSR11
CRSR13: CAILE D,167
MOVEI D,167
ADDI D,10 ;H AND V RANDOMLY WANT 10 ADDED
CRSR14: MOVSI D,400000(D) .SEE CNPCD1 ;KEEP LH FROM BEING ZERO
HRRI D,(TT)
JRST CRSRP7
CRSRP1: PUSHJ P,FORCE1
MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
MOVEI TT,F.CHAN
.CALL RCPOS ;GET CURRENT CURSOR POSITION
.VALUE
TLNE F,FBT<EC> ;GET ECHO MODE POSITION
MOVE D,R ; IF FILE IS FOR ECHO AREA
MOVEI TT,(D) ;CONS THEM UP FOR LOSER
JSP T,FIX1A
MOVEI B,(A)
HLRZ TT,D
JSP T,FIX1A
JRST CONS
CRSRMP: PUSH FXP,T
CRSRM1: HLRZ A,@(P)
MOVE T,(FXP)
MOVEI TT,(T)
ADDI TT,(P)
PUSH P,1(TT)
TRNE T,1
PUSH P,2(TT)
PUSH P,A
PUSHJ P,CRSRPS
HRRZ A,@(P)
MOVEM A,(P)
JUMPN A,CRSRM1
POP FXP,T
CRSRN: MOVEI A,TRUTH
JRST PROGN1
] ;END OF IFN QIO
] ;END OF IFN USELESS*ITS
IFN FUNAFL,[
SUBTTL RANDOM ROUTINES TO HANDLE A PSEUDO ALIST
%%FUNCTION: MOVEI D,Q%%FUNCTION
JUMPE A,WNAFOSE
HRRZ C,(A)
JUMPN C,.FUNC1
HLRZ B,(A) ;HALF-ASSED FUNARG BINDING
HRROI TT,(SP) ;ONE LH AS GOOD AS ANOTHER
JSP T,FIX1A
PUSHJ P,XCONS
.FUNC4: MOVEI B,QFUNARG
JRST XCONS
.FUNC1: HLRZ AR2A,(A)
HLRZ AR1,(C)
HRRZ C,(C)
JUMPN C,WNAFOSE
.FUNC2: JUMPE AR1,.FUNC3
HLRZ A,(AR1)
JSP T,SPATOM
JSP T,PNGE1
HLRZ B,(A)
HLRZ B,@(B)
PUSHJ P,CONS
MOVEI B,(C)
PUSHJ P,CONS
HRRZ AR1,(AR1)
JRST .FUNC2
.FUNC3: MOVEI A,(C)
MOVEI B,TRUTH
PUSHJ P,NRECONC
MOVEI B,(AR2A)
PUSHJ P,CONS
JRST .FUNC4
AEVAL: SKIPE A,(P) ;PURPOSELY CRIPPLING POWER OF ALIST
JSP T,FXNV1 ; ROUTINE: FOOEY! - GLS
PUSHJ P,ALIST ;EVAL WITH AN ALIST
SUB P,R70+1
POP P,A
SKIPE T ;ALIST RETURNING NON-ZERO IN T =>
PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED
PUSH P,CAUNBIND
POP FXP,T ;SKIP 1 RETURN
JRST 1(T)
;;; IFN FUNAFL
;;; ALIST CREATES AN ENVIRONMENT AS SPECIFIED BY A GIVEN A-LIST.
;;; AN A-LIST MAY BE:
;;; [1] NIL, MEANING THE TOP-LEVEL ENVIRONMENT.
;;; [2] T, MEANING THE CURRENT ENVIRONMENT (SEE [4]).
;;; [3] A FIXNUM REPRESENTING A SPECPDL POINTER, AS
;;; RETURNED BY THE EVALFRAME FUNCTION AS THE FOURTH
;;; ITEM. THIS INDICATES THE ENVIRONMENT AS OF
;;; THE SPECIFIED FRAME.
;;; [4] ((<SYMBOL> . <VALUE>) . <A-LIST>)
;;; THAT IS, ONTO ONE OF THE OTHER THREE KINDS OF A-LIST
;;; ONE MAY CONS ADDITIONAL VARIABLE-VALUE PAIRS IN
;;; THE USUAL MANNER. THIS IS A "TRUE A-LIST".
;;; THIS ENVIRONMENT IS CREATED BY REBINDING ALL VARIABLES
;;; WHICH HAVE BEEN BOUND SINCE THEN BACK TO THEIR OLD VALUES,
;;; OR TO THE VALUES SPECIFIED BY THE TRUE A-LIST. IF A GIVEN
;;; VARIABLE WAS BOUND SEVERAL TIMES, ONLY ONE REBINDING IS DONE
;;; TO RECREATE THE OLD ENVIRONMENT. THIS IS DONE BY USING THE
;;; LEFT HALF OF A VALUE CELL TO INDICATE WHETHER OR NOT IT
;;; HAS ALREADY BEEN REBOUND. THIS HAS THE CONSEQUENCE THAT
;;; NOQUIT MUST BE TURNED ON DURING THIS OPERATION.
;;; EITHER ONE OR TWO SPECPDL BLOCKS ARE PUSHED, THE SECOND ONE
;;; BEING NECESSARY IF ANY TRUE A-LIST IS GIVEN. THERE ARE FOUR
;;; STEPS TO THE PROCESS:
;;; [1] CHECK ARGUMENT THOROUGHLY FOR ERRORS. IF A TRUE
;;; A-LIST IS GIVEN, ALL SYMBOLS ON THE A-LIST ARE GIVEN
;;; VALUE CELLS IF THEY DON'T HAVE ANY ALREADY.
;;; [2] TURN ON NOQUIT. IF A TRUE A-LIST IS GIVEN, BIND ALL
;;; THE SYMBOLS AS SPECIFIED, MARKING THE VALUE CELLS
;;; AS THEY ARE BOUND, AND NEVER BINDING A SYMBOL TWICE.
;;; WHEN DONE, PUSH THE TRUE A-LIST ONTO THE SPECPDL
;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;; [3] SCAN THE SPECPDL FROM THE POINT SPECIFIED BY THE
;;; SPECPDL POINTER (FROM THE BOTTOM IF NIL), AND BIND
;;; ALL VALUES CELLS SEEN BACK TO THEIR OLD VALUES,
;;; MARKING THEM AS THEY ARE BOUND, NEVER BINDING ONE
;;; TWICE. WHEN DONE, PUSH A POINTER ON THE SPECPDL
;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;; [4] SCAN BACK OVER ALL THE ITEMS PUSHED IN STEPS 2
;;; AND 3, RESTORING THE LAFT HALVES OF ALL THE VALUE
;;; CELLS. TURN OFF NOQUIT AND CHECK FOR INTERRUPTS.
;;; ON RETURN, A-LIST LEAVES T NON-ZERO IFF TWO BIND BLOCKS
;;; WERE PUSHED. IT IS UP TO THE CALLER TO MAKE SURE THAT THE
;;; BLOCK(S) ARE UNBOUND CORRECTLY WITH AUNBIND.
;;; NOTE THAT ERRPOP CAN RECOGNIZE THESE SPECIAL BIND BLOCKS AND
;;; CALL AUNBIND TO UNBIND THEM. THIS IS BECAUSE THE LAST WORD
;;; PUSHED HAS ZERO IN THE LEFT HALF.
ALIST: SKIPN C,-1(P) ;MAKE COPY OF ENVIRONMENT GIVEN A-LIST
ALST1: JUMPE C,ALST3 ;STEP 1 - ERROR CHECKING
CAIN C,TRUTH
JRST ALST3 ;T AND NIL ARE VALID A-LISTS
SKOTT C,LS
JRST ALST2 ;NOPE - GO CHECK IT OUT
HLRZ AR1,(C) ;YUP - CHECK ITS CAR
HRRZ C,(C)
SKOTT AR1,LS
JRST ALST0
HLRZ A,(AR1)
SKOTT A,SY
JRST ALST0
CAIN A,TRUTH
JRST ALST0
HLRZ AR1,(A)
HRRZ B,(AR1)
MOVEI AR1,QUNBOUND
CAIN B,SUNBOUND
JSP T,.SET1
JRST ALST1
;;; IFN FUNAFL
ALST2: TLNN TT,FX ; - DARN WELL BETTER BE A FIXNUM
JRST ALST0
HRRZ TT,(C) ;MUST BE A VALID SPECPDL POINTER
CAML TT,ZSC2
CAILE TT,(SP)
JRST ALST0
ALST3: HLLOS NOQUIT ;TURN ON NOQUIT - MUSTN'T INTERRUPT
HLLOS MUNGP ;ABOUT TO MUNG VALUE CELLS!
MOVEM SP,SPSV ;STEP 2 - PUSH BLOCK FOR TRUE A-LIST
SETZ T, ;T WILL BECOME NON-ZERO IF TRUE
SKIPN C,-1(P) ; A-LIST IS PRESENT AT ALL
ALST3A: JUMPE C,ALST4 ;NIL FOUND
CAIN C,TRUTH
JRST ALST7 ;T FOUND
SKOTT C,LS
JRST ALST4A ;FIXNUM FOUND
HLRZ B,(C)
HRRZ C,(C)
HLRZ A,(B) ;A HAS ATOMIC SYMBOL
HRRZ AR1,(B) ;AR1 HAS ASSOCIATED VALUE
HLRZ B,(A)
HRRZ A,(B)
SKIPGE AR2A,(A) ;SKIP UNLESS VALUE CELL MARKED
JRST ALST3A ;VALUE CELL ALREADY REBOUND
HRLI AR2A,(A) ;PUSH <VALUE CELL,,CURRENT VALUE>
PUSH SP,AR2A ; ONTO SPECPDL; THEN INSTALL
HRROM AR1,(A) ; VALUE FROM ENVIRONMENT, MARKING CELL
AOJA T,ALST3A ;T NON-ZERO => WE PUSHED SOMETHING
ALST4: MOVEI C,SC2 ;NIL => TOP LEVEL ENVIRONMENT
ALST4A: HRRZ C,(C) ;FIXNUM => SPECIFIED ENVIRONMENT
HRRZ B,SPSV
JUMPE T,ALST4C ;IF ANYTHING PUSHED, START NEW BLOCK
PUSH SP,-1(P) ;LEFT HALF BETTER BE ZERO!
PUSH SP,SPSV ;FINISH OFF BLOCK FOR TRUE A-LIST
MOVEM SP,SPSV ;START NEW BLOCK FOR FUNARG POINTER
ALST4C: MOVEI TT,(C) ;STEP 3 - SCAN SPECPDL FROM ENVIRONMENT
ALST5: CAIN TT,(B) ; BACK UP TO POINT WHEN ALIST CALLED
JRST ALST6
HRRZ AR1,(TT) ;GET VALUE FROM SPECPDL
CAMGE AR1,ZSC2 ;IGNORE SPECPDL POINTERS
JRST ALST5A
CAIGE AR1,(SP)
AOJA TT,ALST5
ALST5A: HLRZ A,(TT) ;GET VALUE CELL FROM SLOT
JUMPE A,AL5AB ;IGNORE FROBS ALIST PUSHES!
SKIPGE AR2A,(A) ;IGNORE MARKED VALUE CELLS
AL5AB: AOJA TT,ALST5
HRLI AR2A,(A) ;ELSE PUSH AS BEFORE
PUSH SP,AR2A
HRROM AR1,(A)
AOJA TT,ALST5
;;; IFN FUNAFL
ALST7: HRRZ C,-1(P) ;T => CURRENT ENVIRONMENT
SETZ T, ;ONLY ONE BLOCK PUSHED
HRRZ B,SPSV
ALST6: PUSH SP,C ;STEP 4 - RESTORE VALUE CELLS
ALST6A: CAIN B,(SP)
JRST ALST7A
HLRZ A,(B)
JUMPE A,ALST6B
CAMGE A,ZSC2
HRRZS (A)
ALST6B: AOJA B,ALST6A
ALST7A: PUSH SP,SPSV ;CLOSE BIND BLOCK
HLLZS MUNGP ;VALUE CELLS UNMUNGED
JRST CZECHI ;ALL DONE - CHECK INTERRUPTS
;;; AUNBIND UNDOES A FUNARG BIND BLOCK PUSHED BY ALIST.
;;; IT DOES SO BY SCANNING UP THE SPECPDL FROM THE POINT OF
;;; THE FUNARG ENVIRONMENT, OR BY SCANNING DOWN THE TRUE A-LIST,
;;; CLOBBERING CURRENT VALUES FROM VALUE CELLS INTO SPECPDL
;;; SLOTS OR A-LIST SLOTS AS APPROPRIATE, SO THAT ANY SETQ'S
;;; DONE IN THE CREATED COPY OF THE ENVIRONMENT WILL BE
;;; REFLECTED IN THE ORIGINAL ENVIRONMENT.
AUNBIND: POP SP,T
AUNBN0: MOVEM TT,UNBND3
MOVEM D,AUNBD
MOVEM R,AUNBR
MOVEM F,AUNBF
MOVEI F,1(T)
HRRZ R,(SP)
CAMGE R,ZSC2
JRST AUNBN4
AUNBN1: CAIN F,(SP) ;CLOBBER SETQ'S BACK INTO SPECPDL
JRST AUNBN3
HLRZ D,(F)
AUNBN2: HLRZ TT,(R)
CAIE TT,(D)
AOJA R,AUNBN2
HRRZ TT,(TT)
HRRM TT,(R)
AOJA F,AUNBN1
AUNBN3: MOVE F,AUNBF
MOVE R,AUNBR
MOVE D,AUNBD
SUB SP,R70+1
JRST UNBND0
AUNBN4: ;CLOBBER SETQ'S BACK INTO TRUE A-LIST
AUNBN5: CAIN F,(SP)
JRST AUNBN3
HLRZ D,(F)
JRST AUNBN7
AUNBN6: HRRZ R,(R)
AUNBN7: HLRZ TT,(R)
HLRZ TT,(TT)
HLRZ TT,(TT)
HRRZ TT,(TT)
CAIE TT,(D)
JRST AUNBN6
HLRZ TT,(R)
HRRZ D,(D)
HRRM D,(TT)
AOJA F,AUNBN5
;;; IFN FUNAFL
IAP4A: MOVEM TT,R ;AT THIS POINT, WE MAKE UP AN
HRROI TT,(SP)
JSP T,FIX1A
PUSH P,A
MOVE TT,R
MOVNI R,2
MOVNI T,1
JRST IAP5
APFNG: HRRZ A,(B) ;APPLY FUNARG
HLRZ B,(B)
HRRM B,(C)
PUSH P,A
MOVEM T,APFNG1
PUSHJ P,ALIST
PUSH P,.
HRROI TT,-2(P)
MOVE D,APFNG1
POP TT,2(TT)
AOJLE D,.-1
CAUNBIND: MOVEI D,AUNBIND
MOVEM D,2(TT)
SKIPN T
MOVEI D,CPOPJ
MOVEM D,1(TT)
MOVE T,APFNG1
JRST IAPPLY
APLBL: HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
MOVEM SP,SPSV ;APPLY LABEL EXPRESSION
PUSHJ P,BIND
PUSHJ P,ABIND3
MOVEI A,APLBL1
EXCH A,-1(C)
HLLM A,-1(C)
PUSH FXP,A
JRST IAPPLY
APLBL1: PUSHJ P,UNBIND
POPJ FXP,
] ;END OF IFN FUNAFL
SUBTTL LISTIFY, PNPUT, AND PNGET
LISTIFY: SKIPN R,ARGLOC
JRST LFYER
JSP T,FXNV1 ;LISTIFY UP N ARGS FOR AN LSUBR
MOVM D,TT
CAMLE D,@ARGNUM
JRST LFY0
JUMPGE TT,LFY3
ADD R,@ARGNUM
SUBI R,(D)
LFY3: HRLOI TT,(D) ;SEE HAKMEM (A.I. MEMO 239) ITEM 156
EQVI TT,(R) ;TT GETS <-N-1>,,<CONTENTS OF ARGLOC>
AOBJP TT,FALSE ;ZERO ARGS
PUSH P,R70
MOVEI R,(P) ;T HOLDS LAST POINTER
LFY1: MOVE A,(TT) ;GET ARG
JSP T,PDLNMK
PUSHJ P,NCONS
HRRM A,(R) ;CLOBBER ONTO END OF LIST
MOVEI R,(A) ;ADVANCE LAST POINTER
AOBJN TT,LFY1
JRST POPAJ
PNPUT: JUMPE B,SYCONS
PUSH P,A
SETZM LPNF
JRST INTRN1
$PNGET: PUSHJ P,PNGET
MOVE C,A
JSP T,FXNV2
MOVEI B,0
CAIN TT+1,7
POPJ P,
CAIE TT+1,6
LERR [SIXBIT \FEATURE NOT YET IMPLEMENTED - PNGET!\]
TDZA D,D
$PNG.R: PUSHJ P,CONSFX
SETZ TT,
MOVE R,[440600,,TT]
$PNG3: TLNN D,760000
JRST $PNG.D
$PNG3A: TLNN R,740000
JRST $PNG.R
$PNG4: ILDB T,D ;GET NEXT ASCII BYTE
JUMPE T,$PNGX
ADDI T,40 ;CONVERT, AND STORE
IDPB T,R
JRST $PNG3
$PNG.D: JUMPE C,$PNGX
HLRZ F,(C) ;CONSTRUCT WORD OF ASCII, AND BPTR THERETO
MOVE F,(F)
HRRZ C,(C)
MOVE D,[440700,,F]
JRST $PNG3A
$PNGX: JUMPE TT,.+2
PUSHJ P,CONSFX
JRST NREVERSE
SUBTTL EXAMINE, DEPOSIT, MAKNUM, MUNKAM
DEPOSIT: EXCH A,B
JSP T,FXNV2
JSP T,FLTSKP
JFCL
MOVEM TT,(TT+1)
JRST TRUE
EXAMINE: PUSH P,CFIX1
JSP T,FXNV1
MOVE TT,(TT)
POPJ P,
MAKNUM: MOVEI TT,(A)
JRST FIX1
MUNKAM: JSP T,FXNV1
MOVEI A,(TT)
POPJ P,
SUBTTL SLEEP, LISTEN, ALARMCLOCK
; PUTCODE [SLEEP/LISTEN/ALARM]61,TOP,CUS
$SLEEP: JSP T,FLTSKP
10% JSP T,M30.
10% FMPR TT,[30.0]
10$ JRST .+2
JSP T,IFIX
10% .SLEEP TT, ;SLEEP FOR <TT> 30TH'S OF A SECOND
10$ SLEEP TT, ;SLEEP FOR <TT> SECONDS
JRST TRUE
IFN SAIL,[
CLKINT=717000,,0
IMSKST=721000,,0
IMSKCL=722000,,0
UWAIT=047000,,400034
DEBREAK=047000,,400035
INTUUO=723000,,0
ALARMCLOCK: EXCH A,B
SKIPN @A
JRST SALCK0
MOVEI TT,SAILJOB
MOVEM TT,71
MOVEM B,ACLKTYP
CAIE B,Q$RUNTIME
JRST ALCK1
JSP T,FLTSKP ;RUN TIME IN MICROSECONDS,
JRST .+2 ; ACCURATE TO 4. USEC JIFFIES
JSP T,IFIX
IDIVI TT,1000. ;RUN TIME IN MILLISECONDS
PUSH TT,FXP
SETZ TT,
RUNTIME TT,
ADD TT,@FXP ; RUNTIME WHEN CLOCK SHOULD GO OFF
SUBI FXP,[1,,1]
MOVEM TT,SAIALK
MOVEI TT, SAILINT ;THIS IS WHERE INTERRUPT ROUTINE IS
HRRZM TT,SAILJOB+2
IMSKST SAINTER ;MASK THEM ON
CLKINT 36 ;SET INTERVAL
ALCK4: JRST TRUE
ALCK1: CAIE B,QTIME
JRST ALCK0
JSP T,FLTSKP ;REAL TIME IN SECONDS,
JSP T,M6. ; ACCURATE TO SIXTHS
FMPRI TT,(6.0)
JSP T,IFIX
MOVEM TT,SAIALK ;NUMBER OF CLKINTS TO GO
MOVEI TT,S2ILIN2
HRRZM TT,SAILJOB+2
IMSKST SAINTER ;MASK ON
CLKINT 12 ;ENABLE & GO
JRST ALCK4
SALCK0: IMSKCL SAINTER ;UNMASK
CLKINT 0 ;DISABLE
JRST FALSE
M6.: IMULI TT,6. ;NOTE: DOUBLE SKIP RETURN
JRST 2(T)
] ;END OF IFN SAIL
IFN ITS,[
ALARMCLOCK: EXCH A,B
CAIE B,Q$RUNTIME
JRST ALCK1
JSP T,FLTSKP ;RUN TIME IN MICROSECONDS,
JRST .+2 ; ACCURATE TO 4. USEC JIFFIES
JSP T,IFIX
ASH TT,-2
.SUSET [.SRTMR,,TT]
ALCK4: JUMPL TT,FALSE
JRST TRUE
ALCK1: CAIE B,QTIME
JRST ALCK0
JSP T,FLTSKP ;REAL TIME IN SECONDS,
JSP T,M30. ; ACCURATE TO 30TH'S
FMPRI TT,(30.0)
JSP T,IFIX
LSH TT,1
MOVSI R,400000
JUMPL TT,ALCK2
JUMPN TT,ALCK7
MOVEI TT,1 ;IF 0 SPECIFIED, USE 1/30 SECOND
ALCK7: MOVE R,[600000,,TT]
ALCK2: .REALT R,
JRST ALCK4
M30.: IMULI TT,30. ;NOTE: DOUBLE SKIP RETURN
JRST 2(T)
] ;END OF IFN ITS
IFE QIO,[
LISTEN: PUSH P,CFIX1
10% .LISTEN R,
IFN D10,[
SKIPE LINMODE
SKIPA TT,[SKPINL]
MOVSI TT,(SKPINC)
XCT TT
TDZA R,R
MOVEI R,1
] ;END OF IFN D10
SKIPE PBFTY
AOS R
HRRZ A,RDTYBF
JSP T,LNG1A
ADD TT,R
POPJ P,
] ;END OF IFE QIO
; ENDCODE [SLEEP/LISTEN/ALARM]
SUBTTL REMOB, ARG, SETARG, AND RECLAIM
REMOB: LOCKI ;SUBR 1 - REMOVE ATOMIC SYMBOL FROM OBARRAY
PUSHJ P,INTERN
JRST REMOB7
REMOB2: LOCKI
REMOB7: EXCH A,B ;OBTBL BUCKET # SHOULD BE IN TT
MOVE R,TT
HRRZ D,VOBARRAY
HRRI TT,@TTSAR(D)
PUSHJ P,ARYGT4
HLRZ T,(A)
CAIN T,(B)
JRST REMOB1
REMOB3: MOVE D,A
HRRZ A,(A)
HLRZ T,(A)
CAIE T,(B)
JRST REMOB3
HRRZ T,(A)
HRRM T,(D)
REMOB4: HLRZ TT,(B) ;LEAVE ATOM HEADER IN T
HRRZ TT,1(TT) ;LEAVE PNAME LINK IN TT
JSP T,GCP8L ;CHECK TO SEE THAT SCOS ARE REMOVED FROM SCO TABLE.
SETZB A,B
UNLKPOPJ
REMOB1: HRRZ A,(A)
JSP T,.STOR0
JRST REMOB4
ARG: JUMPE A,ARG3
ARGXX: JSP R,ARGCOM
HRRZ A,(D)
JRST PDLNKJ
ARG3: SKIPN ARGLOC
JRST ARGCM1
HRRZ A,ARGNUM
JRST PDLNKJ
SETARG: JSP R,ARGCOM
MOVE A,B
JSP T,PDLNMK
HRRM A,(D)
POPJ P,
ARGCOM: SKIPN D,ARGLOC
JRST ARGCM0
JSP T,FXNV1
JUMPLE TT,ARGCM8
CAMLE TT,@ARGNUM
JRST ARGCM8
ADD D,TT
JRST (R)
IFN BIGNUM+USELESS,[
RECLAIM: HRRZS A ;GC A PARTICULAR SEXP
JUMPE A,CPOPJ
LOCKI
PUSHJ P,RECL1
MOVEI A,NIL
UNLKPOPJ
] ;END OF IFN BIGNUM+USELESS
SUBTTL P.$X AND FRIENDS
10% DEPURE: JSR POFF ;DEPURIFY A PAGE
10% REPURE: JSR POFF ;REPURIFY A PAGE
SBSYM: JSR POFF ;FIND SUBR NAME (ADR IN RH OF .)
VCLSYM: JSR POFF ;FIND ATOM FOR VC (ADR IN LH OF .)
VCSYM: JSR POFF ;FIND ATOM FOR VALUE CELL
TLSYM: JSR POFF ;PRINT ST ENTRY OF LEFT HALF OF A CELL
TSYM: JSR POFF ;ST ENTRY OF RIGHT HALF
PLSYM: JSR POFF ;PRINT LEFT HALF OF A CELL
PSYM: JSR POFF ;PRINT RIGHT HALF OF A CELL
POF: JSR POFF ;PRINT ARG (POINTER AT LOC 40)
TOF: JSR POFF ;ST ENTRY OF ARG (POINTER IN 40)
10% P%OFF: JSR POFF ;FOR % TYPEOUT MODE IN DDT
10% PPTBL: JSR POFF ;PRINT OUT PURTBL
10% PPPAG: JSR POFF ;PRINT OUT ACTUAL PAGE STATUSES
;POFF: 0
PSYM1: SETOM PSYMF
MOVEM T,PSMTS ;P.$X, DONE IN DDT,
MOVEM R,PSMRS ; WILL PRINT CONTENTS
MOVEI T,LPSMTB ; OF CURRENT OPEN CELL
MOVE R,@PSMTB-1(T) ; IN LISP FORMAT.
MOVEM R,PSMS-1(T)
SOJN T,.-2
HRRZ T,POFF
10% CAIG T,REPURE+1
10% JRST PUFY
PUSH P,CPSYMX
JSP T,ERSTP
MOVEM P,ERRTN
MOVEI T,40
MOVEM T,PS.S
HRRZ R,POFF
IFN ITS,[
MOVEI T,THIRTY+7
CAIN R,P%OFF+1
MOVEM T,PS.S
CAIG R,POF
.BREAK 12,PSMST
] ;END OF IFN ITS
IFN D10,[
HRRZ T,.JBDDT"
HRRZ T,@6(T) ;WHAT A KLUDGE! 6?!!
CAIG R,POF
MOVEM T,PS.S
] ;END OF IFN D10
JSP T,SPECBIND
TTYOFF
TAPWRT
Q% LPTON
IFN MOBIOF, DISPON
V.RSET
10% V.NOPOINT ;FOR PPTBL
IFN USELESS, SETZM TYOSW
Q% MOVE T,VLINEL
Q% MOVEM T,VCHRCT
IFN QIO,[
HRRZ AR1,V%TYO ;UPDATE OUR NOTION OF THE
PUSHJ P,TTYBR1 ; LINENUM AND CHARPOS OF THE TTY,
MOVEI TT,AT.LNN ; SINCE DDT HAS SCREWED IT ALL UP.
HLRZM D,@TTSAR(AR1)
MOVEI TT,AT.CHS
HRRZM D,@TTSAR(AR1)
] ;END OF IFN QIO
;;; FALLS THRU
;;; FALLS IN
HRRZ T,POFF
10% CAIL T,PPTBL+1
10% JRST PPTBL1
MOVE T,PSMTS ;AT THIS POINT ALL ACS WILL HAVE BEEN
MOVE R,PSMRS ; RESTORED SO THAT MOVE A,@ WILL WORK.
MOVE A,PSMS
Q$ MOVE AR1,PSMS+AR1-A
MOVE A,@PS.S ;THUS THIS STUFF WORKS IF . IS AN AC.
HRRZ T,POFF
10% CAIN T,P%OFF+1
10% JRST PSYMP1
CAIN T,POF+1
MOVEI T,PSYM+1
CAIN T,TOF+1
MOVEI T,TSYM+1
SUBI T,SBSYM
TRNE T,1
TLZA A,-1
HLRZS A
LSH T,-1
JRST .+1(T)
JRST PSYMSB ;SB.$X
JRST PSYMVC ;VC.$X AND VCL.$X
JRST PSYMT ;T.$X AND TL.$X AND TP FOO$X
PSYMP: PUSHJ P,PRIN1 ;P.$X AND PL.$X AND PP FOO$X
PSYMQ: MOVEI A,TRUTH ;RETURN POINT TO GET OUT OF PSYM1
JRST ERR2
PSYMX: MOVEI T,LPSMTB
MOVE R,PSMS-1(T)
MOVEM R,@PSMTB-1(T)
SOJN T,.-2
MOVE T,PSMTS
MOVE R,PSMRS
SETZM PSYMF
CPSYMX: POPJ P,PSYMX
IFN ITS,[
PSYMP1: TLNN A,-1 ;LISP MODE TYPEOUT - HACK TWO HALVES
JRST PSYMP
PUSH P,A
HLRZ A,A
PUSHJ P,PRIN1
MOVEI A,", ;SEPARATE HALVES WITH ",,"
REPEAT 2, PUSHJ P,TYO
POP P,A
TLZ A,-1
JRST PSYMP
] ;END OF IFN ITS
PSYMSB: MOVEI B,(A)
PUSHJ P,ERRADR ;ERRADR DOES ALL THE DIRTY WORK!
JRST PSYMQ
Q% FCN.H: ;FAKE CONTROL-H INTERRUPT FROM DDT
Q$ FCN.B: ;FAKE CONTROL-B INTERRUPT FROM DDT
Q% SKIPN INHIBIT
SKIPE NOQUIT
POPJ P,
SKIPGE INTFLG
POPJ P,
IFE QIO,[
PUSH P,A
MOVEI A,1
PUSHJ P,UINT
JRST POPAJ
] ;END OF IFE QIO
;;; FALLS THRU
;;; FALLS IN
IFN QIO,[
PUSH FXP,D
MOVE D,INHIBIT ;CROCK SO THAT A .5LOCKI
AOJE D,POPXDJ ; WON'T STOP US
PUSH FXP,INHIBIT
SETZM INHIBIT
MOVE D,[TTYIFA,,400000+↑B]
PUSHJ P,UINT
POP FXP,INHIBIT
POP FXP,D
POPJ P,
] ;END OF IFN QIO
TOF1: SKIPA T,[TOF]
POF1: MOVEI T,POF
PUSH P,UUOH
EXCH T,UUTSV
JRST @UUTSV
PSYMVC: MOVEI T,(A)
MOVEI A,QUNBOUND
CAIN T,SUNBOUND
JRST PSYMP
SKOTT T,LS
JRST PSVC1
JSP R,GCGEN
PSVC2
PSVC1: MOVEI A,QM
JRST PSYMP
PSVC2: HLRZ A,(D)
HLRZ B,(A)
HRRZ A,(B)
CAIN A,(T)
JRST PSVC3
HRRZ D,(D)
JUMPN D,PSVC2
JRST GCP8A
PSVC3: HLRZ A,(D)
JRST PSYMP
IFN ITS,[
PUFY: .BREAK 12,PSMST
MOVEI TT,@PS.S ;PURIFY THE PAGE THAT . IS ON
MOVE TT+1,TT ;USED BY DP≠X AND RP≠X
MOVEI C,-REPURE(T)
JSP R,IP0
JRST PSYMX
] ;END IFN ITS
;;; TABLE OF CELLS TO SAVE OVER THE PSYM FUNCTIONS
ZZ==. ;BE SURE TO SEE PSMS IF YOU CHANGE THIS TABLE
PSMTB: ;ACCUMULATOR A MUST BE THE FIRST ITEM, AND AR1 THE FOURTH
IRP FOO,,[A,B,C,AR1,AR2A,TT,D,F,40,UUOH,UUTSV,UUTTSV,UURSV,ERBDF,FPTEM]
FOO
TERMIN
IFN USELESS,[
PRINLV
TYOSW
ABBRSW
] ;END OF IFN USELESS
LPSMTB==.-ZZ ;FPTEM AND PCNT ARE SAME LOCATION
10% PSMST: 4,,PS.S-1 ;READ VALUE OF . FROM DDT WITH .BREAK 12,
; PP - A UUO ;PP IS FOR PRINTING OUT AN ADDRESS AS AN S-EXPRESSION:
;PP 34722$X IN DDT WILL PRINT OUT 34722 AS A
; POINTER IN LIST FORMAT.
; TP - A UUO ;TP IS LIKE PP BUT NICELY PRINTS ST ENTRY FOR
; THAT CELL
P.=PUSHJ P,PSYM ;P.$X IS LIKE PP FOO$X WHERE FOO IS RH OF.
PL.=PUSHJ P,PLSYM ;LIKE P., BUT FOR LH OF CURRENT CELL
10% P%=PUSHJ P,P%OFF ;LIKE P., BUT AS A DDT TYPEOUT MODE
VC.=PUSHJ P,VCSYM ;FIND NAME OF VALUE CELL RH OF . ADDRESSES
VCL.=PUSHJ P,VCLSYM ;A CROSS BETWEEN VC. AND PL.
T.=PUSHJ P,TSYM ;A CROSS BETWEEN P. AND TP
TL.=PUSHJ P,TLSYM ;A CROSS BETWEEN PL. AND TP
SB.=PUSHJ P,SBSYM ;FIND NAME OF SUBR ADDRESSED BY RH OF .
10% TBLPUR=PUSHJ P,PPTBL ;PRINT OUT PURTBL IN NICE FORM
10% PAGPUR=PUSHJ P,PPPAG ;PRINT OUT ACTUAL STATUS OF PAGES
Q% HH=PUSHJ P,FCN.H ;FAKE CONTROL-H INTERRUPT FROM DDT
Q$ BB=PUSHJ P,FCN.B ;FAKE CONTROL-B INTERRUPT FROM DDT
10% DP=PUSHJ P,DEPURE ;DEPURIFY PAGE . IS ON
10% RP=PUSHJ P,REPURE ;REPURIFY PAGE . IS ON
; ENDCODE [P.$X]
SUBTTL T.$X AND TBLPUR$X STUFF
PSYMT: PUSHJ P,ITERPRI ;T.$X TYPEOUT, ETC.
MOVEI TT,(A)
ROT TT,-SEGLOG
MOVE TT,ST(TT)
SETZB T,C
MOVNI R,22
PSYMT1: LSHC T,1
TRZN T,1
JRST PSYMT3
MOVEI A,"+
TROE C,1
PUSHJ P,TYO
MOVEI B,PSYMTT+22(R)
CAIL B,PSYMTT+PSYMTL
MOVEI B,[ASCII \??\]
HRLI B,440700
PSYMT2: ILDB A,B
JUMPE A,PSYMT3
PUSHJ P,TYO
JRST PSYMT2
PSYMT3: AOJL R,PSYMT1
MOVEI A,",
REPEAT 2, PUSHJ P,TYO
HLRZ A,TT
PUSHJ P,PRINC
JRST PSYMQ
;;; MUST MATCH THE IRP WHICH DEFINES THESE AS SYMBOLS!
PSYMTT:
IRP TP,,[LS,$FS,$FX,$FL,BN,SY,SA,VC,$FXP,$FLP,$XM,$NXM,PUR,HNK]
ASCII \TP\
TERMIN
PSYMTL==.-PSYMTT
IFN ITS,[
PPTBL1: MOVEI F,-PPTBL-1(T) ;0 => TBLPUR$X, 1 => PAGPUR$X
JSP T,0PUSH-4
MOVE R,[440200,,PURTBL]
MOVEI T,1
PPTBL2: ILDB TT,R
JUMPE F,PPTBL6
.CALL PPTBL8
.VALUE
ASH TT,-41
TRZ TT,1
SKIPGE TT
MOVEI TT,1 ;0=NONX, 1=IMPURE, 2=PURE
PPTBL6: MOVEI A,(FXP)
SUBI A,(TT)
AOS (A)
MOVEI A,"0(TT)
PUSHJ P,TYO
TRNE T,7
AOJA T,PPTBL2
TRNN T,30
JRST PPTBL3
MOVEI A,40
PUSHJ P,TYO
TRNE T,10
AOJA T,PPTBL2
PUSHJ P,TYO
PUSHJ P,TYO
JRST PPTBL4
PPTBL3:
Q$ PUSH FXP,T
PUSHJ P,ITERPRI
Q$ POP FXP,T
CAIN T,NPAGS
JRST PPTBL5
PPTBL4: TLZ R,770000
AOJA T,PPTBL2
PPTBL5: MOVEI R,TYO
MOVNI TT,4
PPTBL7: EXCH TT,(FXP)
JUMPE TT,PPTBL9
MOVEI A,↑I
PUSHJ P,TYO
MOVE A,(FXP)
ADDI A,"4
PUSHJ P,TYO
XCT "-,CTY
MOVEI C,10.
PUSHJ P,PRINI2
POP FXP,TT
PPTBL9: AOJL TT,PPTBL7
JRST PSYMQ
PPTBL8: SETZ
SIXBIT \CORTYP\
1000,,-1(T)
402000,,TT
] ;END OF IFN ITS
SUBTTL PURIFY≠G ROUTINE
IFN ITS,[ ;DOESN'T REALLY WORK FOR D10 YET
PURIFY: JRST NOTINIT ;CLOBBERED BY INIT TO "SETO AR1,"
; SETO AR1, ;FOR PURIFY$G FROM DDT
MOVE P,[-LFAKP-1,,FAKP-1]
MOVE FXP,[-LFAKFXP-1,,FAKFXP-1]
JRST FPURF7
FPURF2: SETZB TT,PSGAOB ;ZERO PURE SEGMENT AOBJN PTR
SETZM NPFFS ;ZERO PURE FREE STORAGE COUNTERS
SETZM NPFFX
SETZM NPFFL
BG$ SETZM NPFFB
SETZM NPFFY2
MOVSI R,400000
SKIPE LDXBLT ;IF ANY XCT CALL AREA, WILL
IORM R,LDXSIZ ; PURIFY, HENCE CAN ADD NO CALLS
IFN D10,[
OUTSTR [ASCIZ \:$PURIFIED$
\]
EXIT 1,
] ;END OF IFN D10
IFN ITS,[
MOVNI R,NPAGS ;SO STEP THROUGH LOSING PURTBL
MOVE D,[440200,,PURTBL] ; TO DECIDE HOW TO MUNG PAGES
IPUR1: ILDB T,D ;GET BYTE FOR NEXT PAGE
JRST .+1(T)
JRST IPUR3 ;0 - DELETE
JRST IPUR4 ;1 - IMPURIFY
JRST IPUR6 ;2 - PURIFY
MOVEI T,400(R) ;3 - HAIRY STUFF - DECODE FURTHER
LSH T,PAGLOG
CAMGE T,BPSL ;CODE 3 SHOULD NEVER APPEAR
.VALUE ; BELOW BINARY PROGRAM SPACE
MOVE F,@VBPORG ;PAGIFY CURRENT VALUE OF
ANDI F,PAGMSK ; BPORG DOWNWARD
CAIGE T,(F) ;ANY CODE 3 PAGE BELOW THAT CAN
JRST IPUR6A ; BE PURIFIED
CAMG T,BPSH ;ANY CODE 3 PAGE BETWEEN BPORG
JRST IPUR2 ; AND BPSH IS LEFT AS IS
CAMG T,HINXM ;ANY PAGE BETWEEN BPSH AND HINXM
.VALUE ; DAMN WELL BETTER BE 0!!!
HRRZ F,PDLFL1 ;ANYTHING BETWEEN HINXM AND
LSH F,PAGLOG ; PDLS MUST BE PURE FREE STORAGE
CAIGE T,(F)
JRST IPUR6A
CAIGE T,BSCRSG ;SCRATCH PAGES ARE IGNORED
JUMPL AR1,IPUR3A ;PDL PAGES MAY OR MAY NOT BE
IPUR2: ADDI TT,1001 ; FLUSHED, DEPENDING ON AR1
TLNN D,730000 ;ONLY 20 2-BIT BYTES PER WORD, NOT 22
TLZ D,770000
AOJL R,IPUR1
JUMPGE AR1,POP1J
MOVE T,[ITSMSK]
MOVEM T,INTMSK
Q$ MOVE T,[ITSMS2]
Q$ MOVEM T,INTMS2
.VALUE [ASCIZ \:≠PURIFIED≠
\]
] ;END OF IFN ITS
] ;END OF IFN ITS (THE BIG ONE)
IFN ITS,[
IPUR3A: SKIPE NOPFLS
JRST IPUR2
SETZ T,
DPB T,D
IPUR3: TRZ TT,400000 ;DELETE A PAGE
.CBLK TT,
.VALUE
JRST IPUR2
IPUR4: .CALL IPUR9 ;CHECK TYPE OF PAGE
.VALUE
JUMPL T,IPUR2 ;ALREADY IMPURE
IOR TT,[4400,,400000]
JUMPG T,IPUR5
.CBLK TT, ;NON-EXISTENT - GET A PAGE
.VALUE
JRST IPUR2
IPUR5: TLZ TT,4000 ;PURE - TRY TO DEPURIFY
.CBLK TT,
JSP F,IP1 ;IF WE LOSE, TRY COPYING
JRST IPUR2
IPUR6A: MOVEI T,2
DPB T,D
IPUR6: .CALL IPUR9 ;CHECK TYPE OF PAGE
.VALUE
JUMPG T,IPUR2 ;ALREADY PURE
JUMPE T,IPUR7 ;CAN'T PURIFY A NON-EXISTENT PAGE
TLZ TT,4400 ;PURIFY AN IMPURE PAGE
TRO TT,400000
.CBLK TT,
IPUR7: .VALUE
JRST IPUR2
] ;END OF IFN ITS
IFN EDFLAG,[
$INSRT EDITOR ;KLUDGY BINFORD EDITOR
]
SUBTTL PURE COPY OF THE READ SYNTAX TABLE
-1,,0 ;FOR NEWRD WILL POINT TO MACRO CHAR LIST
RSXTB2: PUSH P,CFIX1
JSP TT,1DIMF
NIL ;SHOULD NEVER ACTUALLY CALL
0
RCT0:
IFE NEWRD,[ ;OLD VERSION OF PURE READTABLE
IFN SAIL,[
REPEAT 11, 2,,.RPCNT ;SAIL CHARS
500500,,↑I ;TAB
500500,,↑J
400500,,↑K
400500,,↑L
400500,,↑M ;CR
REPEAT 22, 2,,↑N+.RPCNT ;SAIL CHARS
] ;END IFN SAIL
.ELSE,[
REPEAT 10, 400500,,.RPCNT ;↑@ ↑A ↑B ↑C ↑D ↑E ;↑F ↑G
Q% 400500,,↑H ;↑H
Q$ 2,,↑H ;↑H
500500,,↑I ;TAB
REPEAT 7, 400500,,↑J+.RPCNT ;↑J ↑K ↑L ↑M ↑N ↑O ↑P
Q% 400500,,↑Q ;↑Q
Q$ 405540,,QCTRLQ ;↑Q
400500,,↑R ;↑R
Q% 400500,,↑S ;↑S
Q$ 405540,,QCTRLS ;↑S
REPEAT 7, 400500,,↑T+.RPCNT ;WORTHLESS
2,,33 ;ALT MODE
REPEAT 4, 400500,,↑\+.RPCNT ;WORTHLESS
] ;END IFE SAIL
500500,,40 ;SPACE
REPEAT 6, 2,,"!+.RPCNT ;! " # $ % &
404500,,QRDQTE ;'
440500,,"( ;(
410500,,") ;)
2,,"* ;*
10,,"+ ;+
500500,,", ;,
50,,"- ;-
420700,,". ;.
402500,,"/ ;/
REPEAT 10., 4,,"0+.RPCNT ;DECIMAL DIGITS
2,,": ;:
404540,,QRDSEMI ;;
REPEAT 5, 2,,"<+.RPCNT ;< = > ? @
REPEAT 26., 1,,"A+.RPCNT ;ALPHABETIC
REPEAT 3, 2,,133+.RPCNT ;[ \ ]
22,,"↑ ;↑
62,,"← ;←
2,,"` ;ACCENT GRAVE
REPEAT 26., 501,,"A+.RPCNT ;SMALL LETTERS
2,,173 ;LEFT BRACE
404500,,QRDVBAR ;VERTICAL BAR
REPEAT 2, 2,,175+.RPCNT ;RIGHT BRACE, TILDE
401500,,177 ;RUBOUT
IFN .-RCT0-200, WARN [READTABLE LOSSAGE]
402500,,57 ;PSEUDO SLASHIFIER CHARACTER
440500,,50 ;PSEUDO OPEN PARENS
410500,,51 ;PSEUDO CLOSE PARENS
500540,,40 ;PSEUDO SPACE
SA$ REPEAT 574, 400500,,204+.RPCNT ;SAIL CONTROL CHARS
] ;END OF IFE NEWRD
;;; MORE ON NEXT PAGE
IFN NEWRD,[ ;NEW VERSION OF PURE READTABLE
REPEAT 11, RS.BRK+RS.SL1+RS.SL9 + .RPCNT ;WORTHLESS CONTROL CHARS
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 11 ;TAB
REPEAT 21, RS.BRK+RS.SL1+RS.SL9 + 12+.RPCNT ;WORTHLESS
RS.XLT + 33 ;ALTMODE
REPEAT 4, RS.BRK+RS.SL1+RS.SL9 + 34+.RPCNT ;WORTHLESS
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;SPACE
REPEAT 6, RS.XLT + 41+.RPCNT ;! " # $ % &
RS.BRK+RS.SL1+RS.SL9+RS.MAC + 47 ;'
RS.BRK+RS.SL1+RS.SL9+RS.LP + 50 ;(
RS.BRK+RS.SL1+RS.SL9+RS.RP + 51 ;)
RS.XLT + 52 ;*
RS.SL1+RS.SGN + 53 ;+
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 54 ;,
RS.SL1+RS.SGN+RS.ALT + 55 ;-
RS.BRK+RS.SL1+RS.SL9+RS.DOT+RS.PNT + 56 ;.
RS.BRK+RS.SL1+RS.SL9+RS.SLS + 57 ;/
REPEAT 10., RS.SL1+RS.DIG + 60+.RPCNT ;0 - 9
RS.XLT + 72 ;:
RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.ALT + 73 ;;
REPEAT 5, RS.XLT + 74+.RPCNT ;< = > ? @
REPEAT 4, RS.LTR + 101+.RPCNT ;A-D
RS.LTR + RS.SQX + 105 ;E
REPEAT 21., RS.LTR + 106+.RPCNT ;F-Z
REPEAT 3, RS.XLT + 133+.RPCNT ;LBRACK BSLASH RBRACK
RS.ARR+RS.XLT + 136 ;↑
RS.ARR+RS.ALT+RS.XLT + 137 ;←
RS.XLT + 140 ;ACCENT GRAVE
REPEAT 4, RS.LTR + 101+.RPCNT ;A-D L.C.
RS.LTR+RS.SQX + 105 ;E L.C.
REPEAT 21., RS.LTR + 106+.RPCNT ;F-Z L.C.
REPEAT 4, RS.XLT + 173+.RPCNT ;LBRACE VBAR RBRACE TILDE
RS.BRK+RS.SL1+RS.SL9+RS.RBO + 177 ;RUBOUT
RS.BRK+RS.SL1+RS.SL9+RS.SLS + 57 ;PSEUDO SLASH
RS.BRK+RS.SL1+RS.SL9+RS.LP + 50 ;PSEUDO (
RS.BRK+RS.SL1+RS.SL9+RS.RP + 51 ;PSEUDO )
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;PSEUDO SPACE
] ;END OF IFN NEWRD
TLRCT==<.-RCT0>
ZZ==LRCT-TLRCT
IFE NEWRD,[
IFL ZZ-1-2, INFORM READER-TABLE-DEFICIENCY,\<3-ZZ>
.ELSE BLOCK ZZ-3
] ;END OF IFE NEWRD
,,TRUTH ;,,(STATUS *BAR)
TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE)
NIL,,TRUTH ;(STATUS TERPRI),,(STATUS ←)
;;; *BAR=NIL => NO |'S, *BAR=*BAR => ALWAYS, *BAR=T => HEURISTIC
;;; TTYREAD=NIL => ONLY FORCE FEED CHARS LET READ SEE THE TTY BUFFER
;;; ABBREVIATE: 1.1 => ABBREV FILES, 1.2 => ABBREV FLATSIZE/EXPLODE
;;; TERPRI=T => DO NOT OUTPUT AUTOMATIC NEWLINES
;;; ←=T => ALLOW PRIN1/PRINC TO OUTPUT FIXNUMS IN FORM M←N
SUBTTL TOP PAGE PGTOP, AND SOME INSRTS
MOVEI 1,[.] ;THIS WASTEFUL HAC IS MERELY TO INSURE THAT THE LAST
MOVEI 2,[.] ;FEW CONSTANTS ON THIS PART ARE WORTHLESS
MOVEI 3,[.] ;IN CASE THERE ARE MORE ON PASS2 THAN PASS1
PGTOP TOP,[TOPLEVEL, COMMON, AND RANDOM STUFF]
;;; HERE IS A SUNDER HAC - IT MUST BE ABLE TO FIND
;;; <LF>$INSRT<SP>NAME<TABS-OR-SPACES>;COMMENTS ON FILE
IFN MOBIOF,[
$INSRT MOBYIO ;MOBY I/O PACKAGE
]
$INSRT PRINT ;PRINT AND FILE-HANDLING FUNCTIONS
$INSRT ULAP ;UTAPE, LAP, AND AGGLOMERATED SUBRS
$INSRT ARITH ;STANDARD ARITHMETIC FUNCTIONS
;;; REMEMBER THE SUNDER HACK, AND DONT HACK THIS $INSRT
IFN BIGNUM,[
$INSRT BIGNUM ;BIGNUM ARITHMETIC PACKAGE
]
SUBTTL EVAL AND EVALHOOK
PGBOT EVL
EVALHOOK:
JSP TT,LWNACK
LA23,,QEVALHOOK
IFE FUNAFL,[
MOVEI D,QEVALHOOK
CAME T,XC-2
JRST WNALOSE
] ;END OF IFE FUNAFL
POP P,B
AOS D,T
JSP T,SPECBIND
0 B,VEVALHOOK
IFN FUNAFL,[
CAMN D,XC-2
PUSHJ FXP,AEVAL ;SKIP RETURN
] ;END OF IFN FUNAFL
POP P,A
PUSH P,CUNBIND
SKIPN V.RSET
JRST EV0
JRST EVAL0
OEVAL:
IFN FUNAFL,[
JSP TT,LWNACK ;"EXTERNAL" EVAL - LSUBR (1 . 2)
LA12,,QOEVAL ;MAY TAKE ALIST AS SECOND ARG
CAMN T,XC-2
PUSHJ FXP,AEVAL ;SKIP RETURN
] ;END OF IFN FUNAFL
IFE FUNAFL,[
AOJE T,.+3
MOVEI D,QOEVAL
SOJA T,WNALOSE
] ;END OF IFE FUNAFL
POP P,A
EVAL: SKIPN V.RSET ;"INTERNAL" EVAL - ARG IN A
JRST EV0
SKIPN B,VEVALHOOK
JRST EVAL0
JSP T,SPECBIND ;SUPER-RANDOM HACK SO THAT MM
VEVALHOOK ; CAN INVENT A ↑N FOR LISP
CALLF 1,(B)
JRST UNBIND
EVAL0: SKIPE NIL
PUSHJ P,NILBAD
PUSH P,FXP ;EVAL FRAME FORMAT:
HRLM FLP,(P) ; FLP,,FXP
PUSH P,A ; SP,,<FORM>
HRLM SP,(P) ; $EVALFRAME
PUSH P,[$EVALFRAME] ;SEE APPLY FOR FORMAT OF APPLY FRAMES
;FALLS THROUGH
;FALLS IN
;;; EVALUATE A FORM IN A
EV0: JUMPE A,CPOPJ ;NIL => NIL, ALWAYS!!!
MOVEI C,ILIST
SKOTT A,LS
2DIF JRST (TT),EVTB1-1,QLIST .SEE STDISP
EV0A: MOVE AR1,(A) ;FUNCTION ON 0(P), ADDRESS TO JRST TO IN (TT)
HLRZ T,(A)
SKOTT T,LS
2DIF JRST (TT),EVTB2-1,QLIST .SEE STDISP
HLRZ TT,(T)
CAIN TT,QLAMBDA
JRST EXP3
IFN FUNAFL,[
CAIE TT,QFUNARG
CAIN TT,QLABEL
JRST EXP3
] ;END OF IFN FUNAFL
JUMPL C,EV3B
SKIPE B,VOEVAL
JCALLF 1,(B) ;EVALSHUNT
HLRZ A,AR1
TLNN C,777740 ;MAYBE SAVE FUNCTION NAME IN EV0B
MOVEM A,EV0B
PUSH P,EV0B ;NON-ATOMIC FUNCTION, NOT LAMBDA,
PUSH P,C ; LABEL, OR FUNARG
PUSH P,AR1
PUSHJ P,EV0 ;SO EVALUATE THE FORM
POP P,AR1
POP P,C
POP P,EV0B
JRST EV4 ;NOW TRY USING THE RESULT AS A FUNCTION
EVTB1: JRST PDLNKJ ;FIXNUMS EVALUATE TO THEMSELVES
JRST PDLNKJ ;DITTO FLONUMS
BG$ POPJ P, ;GUESS WHAT, FELLAHS
JRST EE1 ;SOME HAIR FOR SYMBOLS
REPEAT HNKLOG, .VALUE ;HUNKS
JRST EV2 ;RANDOMS LOSE
POPJ P, ;ARRAYS EVAL TO SELVES
IFN .-EVTB1-NTYPES+1, WARN [WRONG LENGTH TABLE]
EV2: %WTA EMS25 ;UNEVALUABLE DATUM (RANDOMNESS)
JRST EV0
EVTB2: JRST EV3A ;FIXNUM AS A FUNCTION IS AN ERROR
JRST EV3A ;DITTO FLONUM
BG$ JRST EV3A ;DITTO BIGNUM
JRST EE2 ;SYMBOLS - THE GOOD CASE
REPEAT HNKLOG, .VALUE ;HUNKS
JRST EV3A ;IT'S A TRULY RANDOM FUNCTION!
JRST ESAR ;IT'S AN ARRAY
IFN .-EVTB2-NTYPES+1, WARN [WRONG LENGTH TABLE]
EE1: PUSHJ P,EVSYM ;EVALUATE SYMBOL
POPJ P, ;WIN
JRST EV0 ;LOSE - RETRY
EE2: SETZ R, ;ZERO R FOR HACK TO TRAP AUTOLOAD LOSS
EE2A: HRRZ T,(T) ;CAR (X) IS ATOMIC
JUMPE T,EAL2 ;GET FUNCTION DEFINITION OFF ATOM
HLRZ TT,(T)
HRRZ T,(T)
CAIL TT,QARRAY ;SYMBOL HEADERS FOR FUNCTION MARKERS
CAILE TT,QAUTOLOAD ; ARE LINEAR IN MEMORY
JRST EE2A
2DIF JRST @(TT),ETT,QARRAY
ETT: EAR ;ARRAY
ESB ;SUBR
EFS ;FSUBR
ELSB ;LSUBR
AEXP ;EXPR
EFX ;FEXPR
EFM ;MACRO
EAL ;AUTOLOAD
EAL: HRRI R,(T) ;NOTE THAT WE SAW AUTOLOAD PROPERTY
JRST EE2A
EAL2: JUMPL R,EV3J ;FN UNDEF AFTER AUTOLOAD
JUMPE R,EV3 ;NO AUTOLOAD PROP - TRY EVALING ATOM
MOVEI B,(R)
HLRZ T,(A)
PUSHJ P,IIAL
HLRZ T,(A)
SETO R,
JRST EE2A
EFM: CAIE C,ILIST ;FOUND MACRO
EFMER: LERR EMS21 ;IMPROPER USE OF MACRO
MOVE B,AR1
HLRZ AR1,(T) ;COMMENT THIS CROCK
CAIN A,AR1
PUSHJ P,CONS1
CALLF 1,(AR1) ;SO HAND THE FORM TO THE MACRO
JRST EVAL ; AND RE-EVALUATE THE RESULT
EFX: HLRZ T,(T) ;FOUND FEXPR
HLL T,AR1 ;SO A FEXPR BEHAVES LIKE AN EXPR
PUSH P,T ; WHOSE ONE ARG IS CDR OF THE FORM
HRLI AR1,400000 ;SEE IAP4 FOR EXPLANATION OF THIS HACK
PUSH P,AR1 ; WHICH ALLOWS FEXPRS AN ALIST ARG
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T) ;FOUND EXPR
HLL T,AR1
EXP3: PUSH P,T ;FOUND LAMBDA, LABEL, FUNARG
MOVEI A,(AR1)
CIAPPLY: MOVEI TT,IAPPLY
JRST (C)
EFS: HLRZ T,(T) ;FOUND FSUBR
MOVEI C,ESB3 ;THIS IS SO WE DON'T EVAL THE ARGS!
JRST ESB2
ELSB: PUSH P,CPOPJ ;FOUND LSUBR
HLLM AR1,(P)
MOVE R,T
HLL R,AR1
MOVEI TT,ELSB1
HRRZ A,AR1
JRST (C)
ELSB1: MOVEI A,NIL ;A HAS NIL WHEN ENTERING AN LSUBR
HLRZ D,(R)
SKIPN V.RSET
JRST (D)
HLRZ R,R
PUSHJ P,ARGCK0 ;CHECK OUT NUMBER OF ARGS
JRST ESB6
JRST (D)
ESAR: SKIPA TT,T ;FOUND SAR
EAR: HLRZ TT,(T) ;FOUND ARRAY
MOVEI R,(TT)
SKOTT TT,SA
JRST EV3A
EAR3: HRRZ T,ASAR(R)
CAIN T,ADEAD
JRST EV3A ;AHA! THIS ARRAY IS DEAD!
PUSH P,R
MOVEI T,EAR1 ;MUST DO SOME HAIR SO THAT
JRST ESB4 ; INTERRUPTS WON'T SCREW US
EAR1: MOVE T,LISAR ;DO NOT MERGE THIS WITH IAPAR1
JRST @ASAR(T) ; - SEE ESB3
ESB: HLRZ R,AR1 ;FOUND SUBR
HLRZ T,(T)
ESB4: MOVEI TT,ESB1
ESB2: MOVEI A,(AR1) ;A GETS LIST OF ARGS
HLL T,AR1
PUSH P,T ;STORE ADDRESS OF SUBROUTINE FOR FN
JRST (C) ;GO SOMEWHERE OR OTHER
ESB1: PUSHJ P,ARGCHK
JRST ESB6
MOVE TT,[A,,A+1]
MOVEI A,Q..MIS
BLT TT,A+NACS-1
JSP R,PDLA2(T)
ESB3: HRRZ TT,(P)
CAIN TT,EAR1 ;HACK TO HELP EAR1 WIN
JRST ESB3C
ESB3A: SKIPN V.RSET
POPJ P, ;ADDRESS OF SUBR IS ON STACK
MOVEI TT,CPOPJ ;WELL, MAYBE DO SOME *RSET HAIR
HLL TT,(P)
EXCH TT,(P)
JRST (TT)
ESB3C: HRRZ TT,-1(P)
MOVEM TT,LISAR ;SAR PROTECTED BY BEING IN LISAR
POP P,-1(P)
JRST ESB3A
EV3: JUMPL C,EV3B ;C<0 => TOO MANY RE-EVALS OF A FN
HLRZ A,AR1
HLRZ A,(A)
HRRZ A,@(A) ;GET VALUE OF ATOMIC FUNCTION
CAIN A,QUNBOUND ;IT'S UNBOUND. LOSE, LOSE, LOSE...
JRST EV3A
TLNN C,777740 ;SAVE FN NAME IN EV0B, MAYBE
HLRZM AR1,EV0B
EV4: ADD C,[1←34.] ;THIS SIZE OF THIS QUANTITY CONSTRAINS
EV4B: HRL AR1,A ; THE # OF TIMES WE MAY RE-EVAL THE FN
MOVEI A,AR1
JRST EV0A
SUBTTL SYMEVAL
SYMEV0: %WTA NASER
SYMEVAL: JUMPE A,CPOPJ ;SUBR 1
JSP T,SPATOM
JRST SYMEV0
PUSHJ P,EVSYM
POPJ P, ;WON
JRST SYMEVAL ;LOST
;;; EVALUATE ATOMIC SYMBOL. SKIPS ON FAILURE (AFTER DOING ERROR).
EVSYM: HLRZ T,(A) ;T GETS POINTER TO SYMBOL BLOCK
HRRZ T,@(T) ;AR1 GETS VALUE FROM VALUE CELL!!!
CAIN T,QUNBOUND
JRST EE1A ;FOOBAR! VALUE CELL CONTAINS UNBOUND
MOVEI A,(T) ;SO THE VALUE IS THE RESULT OF EVAL
POPJ P,
EE1A: %UBV MES6 ;UNBOUND VAR
JRST POPJ1
;;; END OF EVSYM ROUTINE
SUBTTL APPLY, *APPLY, SUBRCALL, LSUBRCALL, ARRAYCALL, FUNCALL
APPLY: CAME T,XC-2 ;"EXTERNAL" APPLY - SUBR (2 . 3)
JRST AP4 ;MAY TAKE A THIRD ALIST ARG
JSP R,PDLA2(T)
.APPLY: ;SUBR 2 (*APPLY)
AP3: SKIPN V.RSET
JRST AP3A
PUSH P,B
PUSH P,FXP
HRLM FLP,(P)
PUSH P,A
HRLM SP,(P)
PUSH P,[$APPLYFRAME]
AP3A: MOVEI AR1,(B) ;"INTERNAL" APPLY -
HRL AR1,A ; FUNCTION IN A, LIST OF ARGS IN B
MOVEI A,AR1
MOVEI C,AP2 ;THIS CROCK LETS US SHARE CODE WITH
JRST EV0A ; EVAL BY PREVENTING EVAL'ING OF ARGS
AP2: MOVEI T,0 ;DE-LISTIFY THE ARGS AND STACK THEM
JUMPE A,(TT) ; ON THE PDL, AND ALSO COUNT THEM
PUSH P,(A) ;DOING THINGS THIS WAY AVOIDS
HLRZS (P) ; DESTROYING ANY OTHER ACS
HRRZ A,(A)
SOJA T,.-4
AP4:
IFN FUNAFL,[
JSP TT,LWNACK ;APPLY WITH AN ALIST (GOOD GRIEF!)
LA23,,QAPPLY
MOVEM T,APFNG1
SKIPE A,(P) ;PURPOSELY CRIPPLING THE POWER OF
JSP T,FXNV1 ; THE ALIST ROUTINE: FOOEY! - GLS
PUSHJ P,ALIST ;SO CREATE MORONIC ALIST ENVIRONMENT
EXCH T,APFNG1
JSP R,PDLA2(T)
SKIPE APFNG1 ;ALIST RETURNING NON-ZERO IN T =>
PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED
PUSH P,CAUNBIND
JRST AP3
] ;END OF IFN FUNAFL
IFE FUNAFL,[
MOVEI D,QAPPLY
JRST WNALOSE
] ;END OF IFE FUNAFL
SUBRCALL: JSP TT,FWNACK ;LSUBR (2 . 7)
FA234567,,QSUBRCALL
JSP TT,JLIST
ADDI T,1
JSP R,PDLARG
POP P,TT
JSP D,PTRCHK
PUSHJ P,(TT)
RETTYP: POP P,D ;PURELY FOR TYPE CHECKING
CAIN D,QFIXNUM
JSP T,FXNV1
CAIN D,QFLONUM
JSP T,FLNV1
POPJ P,
%LSUBRCALL: JSP TT,FWNACK ;FSUBR
FA2N,,Q%LSUBRCALL
JSP TT,JLIST
MOVEI D,(P)
ADDI D,(T)
MOVEI TT,RETTYP
EXCH TT,1(D)
JSP D,PTRCHK
AOJA T,(TT)
PTRCHK: CAIL TT,BEGFUN
CAIL TT,ENDFUN
JRST .+2
JRST (D)
CAML TT,BPSL
CAML TT,@VBPORG
JRST PTRCKE
JRST (D)
%ARRAYCALL: JSP TT,FWNACK ;FSUBR
FA76543,,Q%ARRAYCALL
JSP TT,JLIST
MOVEI D,(T)
ADDI D,(P) ;FALLS INTO FUNCALL
%ARR7: HRRZ A,1(D)
SKOTT A,SA
SOJA T,%ARR0
MOVEI B,CPOPJ
EXCH B,(D)
HLRZ TT,@1(D) .SEE ASAR
MOVEI F,AS<SX>
CAIN B,QFIXNUM
MOVEI F,AS<FX>
CAIN B,QFLONUM
MOVEI F,AS<FL>
TRNN TT,(F)
JRST %ARR0A
FUNCALL: MOVEI D,QFUNCALL ;LSUBR (1 . 777)
JUMPE T,WNALOSE ;(FUNCALL F X1 X2 ... XN) IS LIKE
FUNCA1: SKIPN V.RSET ; (APPLY F (LIST X1 X2 ... XN))
AOJA T,IAPPLY ;IN *RSET MODE, WE FAKE
ADDI T,1 ; OUT THE UUO STUFF
MOVEI TT,(P) ; INTO DOING THE APPLY
ADDI TT,(T) ; FRAME HACKERY FOR US
MOVEI B,CPOPJ
EXCH B,(TT)
JCALLF 16,(B)
;;; VERY INTERNAL APPLY, FOR USE PARTICULARLY WITH "CALL" UUO'S
;;;
;;; STATE OF WORLD AT ENTRANCE TO IAPPLY:
;;; T HAS -<NUMBER OF ARGS ON PDL>.
;;; PDL HAS ARGS ON IT; BELOW THEM IS A SLOT
;;; WITH THE FUNCTION IN THE RIGHT HALF.
;;; THE FUNCTION'S NAME IS MAYBE IN THE LEFT HALF.
;;; C IS USED PRIMARILY TO POINT TO THIS LATTER SLOT; AND, AS
;;; USUAL, THE LEFT HALF HELPS TO LIMIT FUNCTION RE-EVALS.
;;; IF THERE IS ONLY ONE ARG ON THE STACK, 400000 IN THE LEFT
;;; HALF OF THE PDL SLOT MEANS FUNCTION IS A FEXPR, AND MAY
;;; THEREFORE TAKE AN EXTRA (A-LIST) ARGUMENT.
IAPPLY: MOVE C,T ;STATE OF WORLD AT ENTRANCE:
ADDI C,(P) ; T HAS -<NUMBER OF ARGS ON PDL>
ILP1: HRRZ A,(C) ; NEXT PDL SLOT HAS FUNCTION IN RH,
SKOTT A,LS
2DIF JRST (TT),APTB1-1,QLIST ;FN IS NOT LIST STRUCTURE
HRRZ B,(A)
HLRZ A,(A)
CAIN A,QLAMBDA
JRST IAPLMB ;IT'S A LAMBDA
IFN FUNAFL,[
CAIN A,QFUNARG
JRST APFNG ;IT'S A FUNARG (MORE GOOD GRIEF!)
CAIN A,QLABEL
JRST APLBL ;IT'S A LABEL (SUPER GOOD GRIEF!)
] ;END OF IFN FUNAFL
PUSH P,C
PUSH FXP,T
HRRZ A,(C)
JUMPL C,IAP2A ;JUMP IF WE'VE RE-EVAL'ED TOO MUCH
PUSHJ P,EV0 ;ELSE EVAL THE FUNCTIONAL FORM
POP P,C ; AND TRY IT AGAIN...
POP FXP,T
ILP1B: MOVE B,(C)
HRRM A,(C)
TLNN B,-1
HRLM B,(C) ;PUTS FUNCTION NAME IN LH IF NOT THERE
TLO C,400000
JRST ILP1
APTB1: JRST IAP2A ;FIXNUMS ARE NOT FUNCTIONS!
JRST IAP2A ;NOR FLONUMS
IFN BIGNUM, JRST IAP2A ;NOR BIGNUMS ALREADY
JRST IAPATM ;SYMBOLS ARE OKAY, BUT JUST BARELY
REPEAT HNKLOG, .VALUE ;HUNKS
JRST IAP2A ;TRUE RANDOMS ARE OUT!
JRST IAPSAR ;IT'S AN ARRAY - OKAY, I GUESS
IAPATM: HRRZ B,(A) ;APPLY GOT ATOMIC FUNCTION
HRRZS 1(C) ;KILL POSSIBLE 400000 BIT DUE TO FEXPR
TDZA R,R
IAPAT2: HRRZ B,(B)
IAPAT3: JUMPE B,IAPIA1 ;GRAB FUNCTION FROM PROP LIST
HLRZ TT,(B)
HRRZ B,(B)
CAIL TT,QARRAY ;REMEMBER, FUNCTION PROPS ARE
CAILE TT,QAUTOLOAD ; LINEAR IN MEMORY
JRST IAPAT2
2DIF JRST @(TT),IATT,QARRAY
IATT: IAPARR ;ARRAY
IAPSBR ;SUBR
IAPSBR ;FSUBR
IAPLSB ;LSUBR
IAPXPR ;EXPR
IAPXPR ;FEXPR
IAPAT2 ;IGNORE MACROS
IAPIAL ;AUTOLOAD
IAPIAL: HRRI R,(B)
JRST IAPAT2
IAPIA1: JUMPL R,IAP2J
JUMPE R,IAP2
MOVEI B,(R)
MOVEI T,(A)
PUSHJ P,IIAL
HRRZ B,(A)
SETO R,
JRST IAPAT3
IIAL: PUSH P,A
HLRZ A,(B)
PUSHJ P,AUTOLOAD
JRST POPAJ
IAPSAR: SKIPA TT,A ;APPLY A SAR
IAPARR: HLRZ TT,(B) ;APPLY AN ARRAY
MOVEM TT,LISAR ;FOR INTERRUPT PROTECTION ONLY
MOVEI R,(T)
MOVEI TT,IAPAR1
JRST IAPSB1
IAPSBR: HLRZ TT,(B) ;APPLY A SUBR
HRRZ R,(C)
IAPSB1: HRRM TT,(C)
JRST ESB1
IAPAR1: MOVE TT,LISAR
JRST @ASAR(TT)
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAPLSB: MOVEI TT,CPOPJ
HRRM TT,(C)
MOVE R,B
JRST ELSB1
IAP2: JUMPL C,IAP2A
HRRZ A,(C) ;APPLY FUNCTIONAL FROM VALUE CELL
HLRZ A,(A)
HRRZ A,@(A)
CAIE A,QUNBOUND ;FOOBAR! IT'S UNBOUND
JRST ILP1B
JRST IAP2A
IAPLMB: HLRZ TT,(B) ;APPLY A LAMBDA EXPRESSION
MOVEI D,(TT)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNE D,SY
JUMPN TT,IAP3
SETZ D, ;IMPORTANT THAT D BE NON-NEG - SEE IAP4
MOVEI C,(TT)
HRRZ B,(B)
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;NO MORE ARGS
JUMPE TT,QF2A ;TOO MANY ARGS SUPPLIED
IAP5: HLRZ A,(TT)
SKIPE V.RSET
JRST IAP5B
IAP5C: MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1) ;SEE COMMENT AT EFX - ALLOWS
HRLM A,(AR1) ; A FEXPR TO TAKE AN A-LIST ARG
HRRZ TT,(TT)
AOJA T,IPLMB1
IAP5B: MOVEI D,(A)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNN D,SY
JRST LMBERR
JRST IAP5C
IPLMB2: JUMPN TT,IAP4 ;TOO FEW ARGS SUPPLIED
JUMPN R,IPLMB4 ;NO LAMBDA LIST IN FUN
POP P,TT
HRRI TT,CPOPJ ;LAMBDA LIST IS NULL
SKIPE V.RSET
PUSH P,TT
HRRZ A,(B)
JUMPN A,LMBLP
HLRZ A,(B)
JRST EVAL
IPLMB4: MOVEM SP,SPSV
SKIPA
IPLM4A: PUSHJ P,BIND ;BIND VALUES TO LAMBDA VARS
POP P,AR1 ;FUN HAS A NON-NL LAMBDA LIST
HLRZ A,AR1
AOJLE R,IPLM4A
SKIPN V.RSET
JRST IPLMB5
HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
IPLMB5: JSP T,SPECX
HRRZ AR1,(B)
PUSH P,CUNBIND
HLRZ A,(B)
JUMPE AR1,EVAL ;A GENERALIZED LAMBDA, WITH NON-NULL LAMBDA LIST
LMBLP: PUSH P,B ;FOR GENERALIZED LAMBDAS, EVALUATES A SEQUENCE OF EXP'S
HLRZ A,(B)
PUSHJ P,EVAL
LMBLP1: POP P,B
HRRZ B,(B)
LMBLP2: JUMPN B,LMBLP
POPJ P,
IPROGN: MOVEI A,NIL ;INTERNAL PROGN
JRST LMBLP2
IAP3: MOVEI A,(TT) ;APPLY LEXPR
MOVN TT,T
CAIL TT,XHINUM
JRST LXPRLZ
MOVEI AR1,CPOPJ
HRRM AR1,(C)
MOVEI AR1,IN0(TT)
MOVEM SP,SPSV
PUSHJ P,BIND
MOVEI C,(C)
EXCH C,ARGLOC
HRLI C,ARGLOC
PUSH SP,C ;BIND ARGLOC TO LOC OF ARGS ON PDL
EXCH AR1,ARGNUM
HRLI AR1,ARGNUM
PUSH SP,AR1 ;BIND ARGNUM TO NUMBER OF ARGS
JSP T,SPECX
HRRZ B,(B)
PUSHJ P,LMBLP
SKIPN T,@ARGNUM
JRST UNBIND
HRLS T
SUB P,T
JRST UNBIND
CUNBIN: JRST UNBIND
IAP4: JUMPGE D,QF3A
AOJN R,QF3A
IFE FUNAFL, JRST QF2A
IFN FUNAFL, JRST IAP4A ;FEXPR OF TWO ARGS
SUBTTL FUNCTION, QUOTE, DECLARE, COMMENT, SETQ, AND, OR
FUNCTION: SKIPA D,CQFUNCTION ;FEXPR 1
QUOTE: MOVEI D,QQUOTE ;FEXPR 1
JUMPE A,WNAFOSE
HRRZ TT,(A)
JUMPE TT,$CAR
JRST WNAFOSE
DECLARE: MOVEI A,QDECLARE ;FSUBR (IGNORES ARG)
POPJ P,
$COMMENT: MOVEI A,Q$COMMENT ;FSUBR (IGNORES ARG)
POPJ P,
SETQ: PUSH P,A
SET1: HLRZ A,@(P)
JSP D,SETCK
HRRZ B,@(P)
JUMPE B,SETWNA
PUSH P,A ;ATOM TO BE SETQD
HLRZ A,(B)
HRRZ B,(B)
MOVEM B,-1(P)
PUSHJ P,EVAL
POP P,AR1
JSP T,.SET
SKIPE (P)
JRST SET1
JRST POP1J
$AND: HRLI A,TRUTH
$OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,POPAJ
MOVSI C,(SKIPE (P))
TLNE A,-1
MOVSI C,(SKIPN (P))
XCT C
JRST POPAJ
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
SUBTTL PROG, PROGV, RETURN, GO
PROG: HLRZ AR2A,(A) ;FSUBR
HRRZ A,(A)
PUSH P,A
SETZ C,
JSP T,PBIND ;BIND PROG VARIABLES TO NIL
POP P,A
PUSHJ P,PG0 ;EVALUATE PROG BODY
MOVEI A,NIL
JRST UNBIND ;UNBIND VARIABLES
PG0: PUSH P,PA3
PUSH P,PA4
PUSH P,SP
PUSH P,FXP
PUSH P,FLP
LPRP==.-PG0+1 ;LENGTH OF PROG PDL, IE HOW MUCH PROG HAS
MOVEM P,PA4 ;CAUSED TO BE PUSHED
HRLS A
MOVEM A,PA3
PG1: HLRZ T,PA3
PG1A: JUMPE T,PRXIT ;NORMAL EXIT
HLRZ A,(T)
HRRZ T,(T)
HRLM T,PA3
SKOTT A,LS
JRST PG1
PUSHJ P,EVAL
PG0A: JRST PG1
;;; JSP T,VBIND ;LIST OF SYMBOLS IN AR2A, VALUES IN A
;;; BINDS EACH SPECIAL VARIABLE IN THE LIST TO CORRESPODNING VALUES.
;;; IF VALUES LIST TOO SHORT, NIL GETS USED (OBVIOUSLY).
VBIND: MOVEI C,(A) ;INTERPRETED AND COMPILED PROGV COME HERE
PBIND: MOVEM SP,SPSV ;BIND PROG VARIABLES
JUMPE AR2A,SPECX
MOVEI AR1,NIL
PBIND1: HLRZ A,(AR2A) ;NEXT VARIABLE
HLRZ AR1,(C) ;NEXT VALUE
PUSHJ P,BIND ;BIND!
HRRZ C,(C)
HRRZ AR2A,(AR2A)
JUMPN AR2A,PBIND1
JRST SPECX
PROGV: HRRZ B,(A) ;FSUBR
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
PUSH P,C
PUSH P,B
PUSHJ P,EVAL ;GET LIST OF VARIABLES
EXCH A,(P)
PUSHJ P,EVAL ;GET LIST OF VALUES
POP P,AR2A
JSP T,VBIND ;BIND VARIABLES
POP P,B
PUSHJ P,LMBLP ;EVAL REST LIKE LAMBDA BODY
JRST UNBIND
RETURN: JSP T,BKERST ;SUBR 1
MOVE P,PA4
AOS -LPRP+1(P) ;RETURN CAUSES SKIP
PRXIT: POP P,FLP ;PROG EXIT
POP P,FXP
POP P,TT
PUSHJ P,UBD0
POP P,PA4
ERRP4: POP P,PA3
RHAPJ: MOVEI A,(A)
CQFUNCTION: POPJ P,QFUNCTION
GO: JSP TT,FWNACK
FA1,,QGO
HLRZ A,(A)
GO2: JSP T,SPATOM ;LEAVES TYPE BITS IN TT
JRST GO3
GO1: JSP T,BKERST
HRRZ T,PA3
PG5: JUMPE T,EG1
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,(A)
JRST PG5A
TLNN A,400000 ;4.9 BIT => GO TAG IS NUMERIC
JRST PG5
MOVEI D,(TT)
LSH D,-SEGLOG
SKIPL D,ST(D)
TLNN D,FX+FL
JRST PG5
MOVE TT,(TT)
CAME TT,(A)
JRST PG5
PG5A: MOVE P,PA4
MOVE FLP,(P)
MOVE FXP,-1(P)
HRRZ TT,-2(P)
PUSHJ P,UBD
JRST PG1A
GO3: TLNN TT,FX+FL
JRST GO3A
GO3B: MOVE TT,(A) ;SET 4.9 BIT OF A IF TAG IS NUMERIC
CAML TT,[-XLONUM]
CAIL TT,XHINUM ; BUT NOT INUM
TLO A,400000
JRST GO1
GO3A: PUSHJ P,EVAL ;IF ARG TO GO ISN'T ATOMIC, DO ONE EVAL AND TRY AGAIN
MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,FX+FL
JRST GO3B
TLNE TT,SY
JRST GO1
JRST EG1
SUBTTL DO FUNCTION
DO: PUSH P,PA4
SETZM PA4
PUSH FXP,R70 ;A "DO SWITCH" TO MARK EXPANDED FORMAT
PUSH P,A
HLRZ A,(A)
SKOTT A,LS ;HUNKS WIN AS WELL AS LISTS
JUMPN A,DO4A
HRROM A,(FXP)
HLRZ A,@(P) ;SETUP FOR MULTIPLE INDICES
HRRZ C,@(P)
HLRZ B,(C)
JRST DO4
DO4A: MOVE A,(P) ;SINGLE INDEX DO
HRRZ B,(A)
HRRZ B,(B)
HRRZ B,(B)
MOVE C,B
DO4: HRRZ C,(C)
MOVEM A,(P) ; (P) PROG BODY
DO4C: SKOTT B,LS
JUMPN B,DOERRE
PUSH P,B ; -1(P) ENDTEST
PUSH P,C ; -2(P) DO VARS LIST
MOVE A,-2(P)
MOVSI R,600000 ;EVALUATE AND SETUP INITIAL VALUES
SKIPN -1(P)
MOVSI R,400000 ;200000 BIT SAYS STEPPERS ARE OKAY
PUSHJ FXP,DO5
SKIPN -1(P)
JRST DO4D
DO7: HLRZ A,@-1(P)
PUSHJ P,EVAL
JUMPN A,DO8
DO7A: MOVE A,(P)
PUSHJ P,PG0 ;DO PROG BODY (MAY SKIP ON RETURN STATEMENT)
JRST DO2
DO9: MOVE B,-2(P)
SUB P,R70+3 ;BREAK OUT OF BODY BY RETURN STATEMENT
POP P,PA4
SUB FXP,R70+1
JUMPN B,UNBIND
POPJ P,
DO8: SKIPN A,(FXP)
JRST DO9 ;SIMPLE DO FORMAT
HRRZ B,@-1(P) ;DO PASSED ENDTEST, AND RETURNS A VALUE
PUSHJ P,IPROGN
JRST DO9
DO2: MOVE A,-2(P)
MOVEI R,0 ;DO STEPPING FUNCTIONS
PUSHJ FXP,DO5
JRST DO7
DO4D: MOVE A,(P)
PUSHJ P,PG0
SETZ A, ;DEFAULT VALUE OF ONCE-THROUGH DO IS NIL
JRST DO9
DO5: JUMPE A,DO6 ;DOES PARALLEL SETQS - ON LISTS LIKE (I V1 V2)
PUSH P,A ;WILL DO (SETQ I V1) IF R < 0
SKIPE -1(FXP) ;WILL DO (SETQ I V2) IF R > 0
HLRZ A,(A) ;IF DOSW INDICATES SINGLE INDEX, THEN ONLY ONE LIST
DO5Q: MOVEI B,(A)
JUMPGE R,DO5F
SKOTT A,LS
JRST DOERR
HLRZ A,(B)
JSP T,SPATOM
JRST DOERR
TLNE R,200000
JRST DO5F
HRRZ A,(B)
JUMPE A,DO5F
HRRZ A,(A)
JUMPN A,DO5ER
DO5F: HLRZ A,(B)
HRLM A,(P)
HRRZ A,(B)
JUMPL R,DO5E
JUMPE A,DO5B
HRRZ A,(A)
JUMPN A,DO5D
DO5B: POP P,A
SOJA R,DO5C
DO5E: JUMPE A,DO5G ;(I) IS SAME AS (I NIL) ON INITIAL VALUE
DO5D: HLRZ A,(A)
PUSH FXP,R
PUSHJ P,EVAL
POP FXP,R
DO5G: HLL A,(P)
EXCH A,(P) ;NOW (P) HAS ATOM,,VALUE
DO5C: HRRZ A,(A)
SKIPN -1(FXP)
MOVEI A,0 ;SO THAT SINGLE FORMAT DO WILL DROP OUT
AOJA R,DO5
DO6: TRNN R,-1 ;[(SETQ I V1) FROM ABOVE]
POPJ FXP, ;FIRST TIME THROUGH, WE ALLOW OLD BINDINGS
JUMPGE R,DO6C ;TO BE REMEMBERED ON THE SPDL FOR LATER UNBINDING
HRRZS R
MOVEM SP,SPSV
DO6A: POP P,AR1
HLRZ A,AR1
PUSHJ P,BIND
SOJG R,DO6A
JSP T,SPECX
POPJ FXP,
DO6C: POP P,AR1 ;DURING THE STEPPING PHASE, AS OPPOSED TO
HLRZ A,AR1 ;THE INITIALIZATION PHASE, WE LET NO BINDINGS
PUSHJ P,BIND ;ACCUMULATE ON THE SPDL
JSP T,SETXIT
SOJG R,DO6C
POPJ FXP,
SUBTTL COND, ERRSET, ERR, CATCH, THROW
COND1: HRRZ A,(T)
COND: JUMPE A,CPOPJ ;ENTRY
PUSH P,A
HLRZ A,(A)
HLRZ A,(A)
CAIE A,TRUTH
PUSHJ P,EVAL
CON3: POP P,T
JUMPE A,COND1 ;IF FIRST OF COND PAIR IS TRUE
HLRZ T,(T)
SKIPA
COND2: POP P,T
HRRZ T,(T)
JUMPE T,CPOPJ ;LOOP FOR GENERALIZED COND PAIR
PUSH P,T
HLRZ A,(T)
PUSHJ P,EVAL
CON2: JRST COND2
BKERST: SKIPN TT,PA4
JRST BKRST1
TLZ TT,-1
SKIPE B,CATRTN
JRST BKRST2
BKRST3: SKIPE B,ERRTN
CAILE TT,(B)
JRST (T) ;NO TROUBLESOME CATCHS OR ERRSETS
BKRST4: MOVEI TT,BKERST
BKRST0: MOVEM TT,-LERSTP(B) ;BREAK UP A TROUBLESOME CATCH OR ERRSET, E.G.
MOVE P,B ;(PROG (A) (ERRSET (RETURN (FOO A))))
JRST ERR1 ;AND THEN TRY BKERST AGAIN
BKRST2: CAILE TT,(B)
JRST BKRST3 ;CATCH ISN'T TROUBLESOME, SO TEST FOR ERRSETS
JRST BKRST4 ;AH, CATCH IS TROUBLESOME!
BKRST1: MOVEI A,LGOR
%FAC EMS22
ERRSET: JSP TT,FWNACK
FA12,,QERRSET
MOVEI C,TRUTH
HRRZ B,(A)
JUMPE B,ERRST3
PUSH P,A
HLRZ A,(B)
PUSHJ P,EVAL
MOVEI C,(A)
POP P,A
ERRST3: JSP T,ERSTP
MOVEM P,ERRTN
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
ERRNX: PUSHJ P,NCONS ;NORMAL EXIT
JRST ERUN0
ERR: JSP TT,FWNACK
FA012,,QERR
JUMPE A,ERR2
HRRZ B,(A)
JUMPE B,.+3
HLRZ B,(B)
JUMPE B,ERR3A
HLRZ A,(A) ;EVAL BEFORE UNBLOCKING
PUSHJ P,EVAL
JRST ERR2
ERR3A: SKIPN ERRTN
JRST LSPRET
MOVEI T,ERR3
EXCH T,-LERSTP(P)
JRST ERR0 ;UNBLOCK THE ERRSET, THEN
ERR3: SKIPE A ;EVAL THE ARG TO ERR
HLRZ A,(A)
PUSH P,T
JRST EVAL
CATCH: JSP TT,FWNACK
FA12,,QCATCH
PUSHJ P,CATHRO
JSP TT,CATPS1
HLRZ A,(B)
PUSHJ P,EVAL
MOVEI B,NIL ;CAUSE MOST RECENT CATCH TO BE THROWN
JRST THROW1
THROW: JSP TT,FWNACK
FA12,,QTHROW
PUSHJ P,CATHRO
PUSH P,A
HLRZ A,(B)
PUSHJ P,EVAL
POP P,B
JRST THROW1
CATHRO: MOVE B,A
HRRZ A,(A)
JUMPE A,CPOPJ
HLRZ A,(A)
POPJ P,
SUBTTL STORE, BREAK, SIGNP
STORE: JSP TT,FWNACK
FA2,,QSTORE
HLRZ B,(A)
PUSH P,B
HRRZ A,(A)
HLRZ A,(A)
PUSHJ P,EVAL
PUSH P,A
STORE7: HRRZ A,-1(P)
SETZM LISAR
PUSHJ P,EVAL
SKIPN V.RSET ;#####HERE IS THE GLITCH FOR *RSET CHECKING ON STORE
JRST STORE9
SKIPN A,LISAR
JRST STORE5
JSP T,ARYSIZ
HLL D,ASAR(A)
TLNE D,AS<SX>
LSH F,-1
TLNN R,200000 ;=> NEGATIVE INDEX
CAIGE F,(R) ;THERE'S PROBABLY A FENCE-POST FOR SX ARRAYS HERE
JRST STORE5
STORE9: POP P,A
SUB P,R70+1
JSP T,.STORE
SETZM LISAR
POPJ P,
BREAK: JSP TT,FWNACK ;FSUBR (1 . 2)
FA12,,QBREAK
HLRZ B,(A) ;BKPT NAME
HRRZ A,(A)
JUMPE A,$BRK0 ;NO SECOND ARG => ALWAYS BREAK
HLRZ A,(A) ;TO-BREAK-OR-NOT SWITCH
PUSH P,B
PUSHJ P,EVAL ;THIS IS A CROCK!!!
POP P,B
JRST $BREAK ;A = BREAKP, B = BREAKID
SIGNP: JSP TT,FWNACK ;FSUBR 2
FA2,,QSIGNP
PUSH P,(A)
HLRZ A,(A)
PUSH P,A
SIGNP0: PUSHJ P,PNGET
HLRZ A,(A)
MOVS T,(A)
HRRZ A,(A)
JUMPN A,SIGNPE
MOVNI A,6
CAIE T,@SPTB+6(A)
AOJL A,.-1
JUMPGE A,SIGNPE
HLLZ A,SPTB+6(A)
SUB P,R70+1
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NUMBERP
JUMPE A,POP1J
POP P,T
HRRI T,TRUE
XCT T
JRST FALSE
SPTB:
IRP Q,,[L,E,LE,G,GE,N]
JUMP!Q TT,(ASCII \Q\)
TERMIN
SUBTTL PROG2, PROGN, EQ, RPLACA, RPLACD
PROG2: MOVEI D,QPROG2
CAMLE T,XC-2
JRST WNALOSE
HRLI T,-1(T)
ADD T,P
MOVE A,2(T)
MOVEM T,P
POPJ P,
PROGN: AOJG T,FALSE
POP P,A
PROGN1: JUMPE T,CPOPJ
HRLI T,-1(T)
ADD P,T
POPJ P,
EQ: CAMN A,B ;SUBR 2 - POINTER IDENTITY PREDICATE
JRST TRUE
JRST FALSE
RPLACA: SKOTT A,LS
JRST RPLCA0
TLNE TT,PUR+VC
JRST RPLCA1
HRLM B,(A)
POPJ P,
RPLACD: ;SUBR 2 - CLOBBER CDR OF FIRST ARG WITH SECOND
SKOTT A,LS
JRST RPLCD2
TLNE TT,PUR
JRST RPLCD1
RPLCD3: HRRM B,(A)
POPJ P,
RPLCD2: JUMPE A,RPLCD0 ;(RPLACD NIL FOO) IS ALWAYS A LOSS
SKIPE T,VCDR
CAIN T,QLIST ;IF CDR = NIL OR LIST, THEN BOMBOUT
JRST RPLCD0 ;SINCE ARG IS NOT LIST OR NIL
CAIN T,QSYMBOL
TLNE TT,SY
JRST RPLCD3 ;IF NOT CDR = SYMBOL, THEN ANYTHING GOES
JRST RPLCD0
PGTOP EVL,[EVAL, APPLY, STUFF OPEN-CODED BY COMPLR]
$INSRT GCBIB ;GARBAGE COLLECTOR AND ALLOCATION STUFF
$INSRT READER ;READ AND RELATED FUNCTIONS
$INSRT ARRAY ;ARRAY PACKAGE
$INSRT FASLOA ;FASLOAD
IFN QIO,[
$INSRT QIO ;NEW MULTIPLE FILE I/O FUNCTIONS
] ;END OF IFN QIO
SUBTTL INTERRUPT HANDLERS
PGBOT INT
IFE QIO,[
IFN ITS,[
;;; ***** MOBY INTERRUPT ROUTINES *****
PINBL: .SPICLR,,XC-1 ;SUSET WORD TO ENABLE INTERRUPTS
PIHOLD: .SPICLR,,R70 ;SUSET WORD TO GAG INTERRUPTS
INT0: EXCH A,INT ;BIG DISPATCH !!!
JUMPL A,INT4
TRZE A,IB.TTY ;1
JRST TTYINT
INT1: TLNN A,(IB.TIMR) ;100000,,0
TLNE A,(IB.ALARM) ;200000,,0
JRST TIMOUT
TRZE A,IB.PDLO ;200000
JRST PDLOV
TRZE A,IB.IOC ;400
JRST IOERR
INT2: TRZE A,IB.ILOP ;I ASSUME THAT THERE WILL NEVER BE ANY
JRST ERRILO ;TWO OF THESE INTERRUPTS TOGETHER -
TLZE A,(IB.PUR) ; ILGL OPERATION, PURE PAGE TRAP, OR
JRST PURPGI ; ILGL MEM REFERENCE, PARITY ERROR
TRZE A,IB.MPV ;20000
JRST INT3
TLZE A,(IB.PARITY)
JRST PARERR
INT4: SKIPN UPIINT
NOINT: .VALUE
JRST @UPIINT
INT3: HRRZ A,IPCLOK
CAIN A,UBD1 ;ALLOW SPDL RESTORATION TO TAKE PLACE
JRST INTEX1 ;EVEN IF ONE SLOT IS CLOBBERED
JRST INTILM
TTYINT: MOVEM A,INTSV
MOVEI A,TYIC
.ITYIC A,
JRST INTEX
JSR CNTROL
INTEX: SKIPE A,INTSV
JRST INT1
INTEX1: MOVE A,INT
.DISMIS IPCLOK
CN.Z: .RESET TYIC, ;SO SUPERIOR WON'T SEE ↑Z AS INPUT
.VALUE [ASCII \:VK \]
JRST 2,@CNTROL
;;; IFN ITS
TIMOUT: MOVEM A,INTSV
SKIPN VALARMCLOCK ;INT FROM FRUSTRATED ALARMCLOCK
JRST TIMO1
MOVEI A,INTEX
MOVEM A,CNTROL ;THIS IS A HACK
MOVE A,INTSV
TLZN A,(IB.ALARM)
JRST TIMO6
MOVEM A,INTSV
MOVSI A,400000 ;REAL TIME INT, SO SHUT OFF CLOCK
.REALT A,
SKIPA A,[QTIME,,3]
TIMO3: MOVE A,[Q$RUNTIME,,3]
SKIPL UNREAL ;MAYBE CLOCK INTS AREN'T PERMITTED NOW
JRST UINT1
MOVSS A ;IF SO, QUEUE IT UP
MOVSM A,UNRRUN-Q$RUNTIME(A)
JRST INTEX
TIMO6: TLZN A,(IB.TIMR)
JRST INTEX ;????
MOVEM A,INTSV
JRST TIMO3
TIMO1: TLNN A,(IB.ALARM)
JRST TIMO7
MOVSI A,400000
.REALT A,
MOVE A,INTSV
TIMO7: TLZ A,(IB.TIMR+IB.ALARM) ;NO ALARM FNCTION, SO FLUSH INTERRUPTS
JUMPN A,INT1
JRST INTEX1
] ;END OF IFN ITS
;;; IFE QIO
IFN D10,[
;;; DECSYSTEM-10 INTERRUPT ROUTINES
INT0: PIOF
MOVEM A,INT ;SAVE REG A
MOVE A,.JBCNI"
TRZE A,IB.PDLOV ;PDL OVERFLOW?
JRST PDLOV ;YEP
TRZE A,IB.MPV ;ILL MEM REF?
JRST INTILM
NOINT: HALT ;I DONT KNOW WHAT THIS IS!
TTYINT: AOSLE UPCOK
JRST 2,@.JBOPC"
MOVEM A,INT
MOVE A,.JBOPC"
MOVEM A,IPCLOK
TTYIN0: SA% OUTSTR [ASCIZ \ππ?↑\]
IFN SAIL,[
SETO A,
CALLI A,400111
OUTSTR [ASCIZ \?↑\] ;FOO ON SAIL CHARACTER SET
] ;END OF IFN SAIL
INCHRW A
SA$ TRZE A,600
SA$ TRZ A,100
SETZM UPCOK
JSR CNTROL
SKIPLE UPCOK
JRST TTYIN0
MOVE A,INT
SETOM UPCOK
JRST 2,@IPCLOK
UPCHK: SKIPLE UPCOK
JRST .+3
SETOM UPCOK
POPJ P,
SETZM UPCOK
MOVEM A,INT
POP P,IPCLOK
JRST TTYIN0
JCLSET: SETZ D,
MOVE R,[440700,,SJCLBUF+1]
TTCALL 10,1
SA$ SKIPN A
SA% JRST JCST4
JRST JCST3
JCST4: INCHRS A
JRST JCST3
CAIE A,↑M ;IF <CR> OR <ALT> OCCURS ON COMMAND
CAIN A,33
JRST JCST3 ;BEFORE A ";", THEN NO JCL
CAIE A,";
JRST JCST4 ;LOOP UNTIL WE FIND A ;
MOVNI D,BYTSWD*LSJCLBUF
JCST2: INCHRS A
JRST JCST1
AOSG D
IDPB A,R
CAIN A,↑M ;<CR> OR <ALT> TERMINATES
JRST JCST1 ;THE COMMAND LINE
CAIE A,33
JRST JCST2
JCST1: SKIPLE D
TDZA D,D
ADDI D,BYTSWD*LSJCLBUF
JCST3: INCHRS A ;MAKE SURE NO SUPERFLUOUS CHAR
JFCL
MOVEM D,SJCLBUF
SETZ A,
IDPB A,R ;INSURE AT LEAST ONE NUL BYTE FOLLOWING THE LINE
JRST (F)
CN.Z: SKIPE A,.JBDDT" ;RETURN TO DDT IF IT EXISTS
JRST (A)
EXIT 1, ;OTHERWISE CRAP OUT TO MONITOR
ALTP: JRST 2,@CNTROL ;WHEN IN DDT, "ALTP$G" IS GOOD
] ;END OF IFN D10
] ;END OF IFE QIO
IFN SAIL,[
SAILINT:IMSKCL SAINTER ;UNMASK
UWAIT ;WAIT FOR UUOS TO FINISH
DEBREAK ;INTERRUPT LEVEL BECOMES USER LEVEL
MOVEM TT,ATTSV ;SAVE TT
MOVE TT,SAILJOB+1
MOVEM TT,SAICONT ;CONTINUE ADDRESS IN RIGHT PLACE
CLKINT 0 ;DISABLE
SETZ TT,
RUNTIME TT, ;WHAT TIME IS IT?
CAMGE TT,SAIALK
JRST SADISMIS ;FOO. NOT LONG ENOUGH
SAHACKIT: SKIPN VALARM
JRST SADISMIS
MOVE TT,ATTSV ;PUT BACK TT
MOVEM A,AINT ;DO IT
HRLZ A,ALCKTYP
HRRI A,3
SKIPN UNREAL
JRST S2RUN
MOVSS A
MOVSM A,UNRRUN-Q$RUNTIME(A)
SADMS0: MOVE A,AINT
SADISMIS: MOVE TT,ATTSV
CLKINT 36 ;ENABLE
INTUUO 0,SAINTER ;MASK ON & RETURN
S2RUN: JSR INTWAIT
JRST .+2
JRST SADMS0
PUSH P,AINT
PUSHJ P,UINT
JRST POPAJ
S2ILIN2:IMSKCL SAINTER
UWAIT
DEBREAK
MOVEM TT,ATTSV
MOVE TT,SAILJOB+1
MOVEM TT,SAICONT
CLKINT 0
SOSLE SAIALK ;TIME YET?
JRST .+2 ;NO
JRST SAHACKIT ;SURE
MOVE TT,ATTSV
CLKINT 12
INTUUO 0,SAINTER
] ;END OF IFN SAIL
IFN QIO,[
;;; NEW-STYLE INTERRUPT TRANSFER VECTOR
ITSMSK=%PI<PAR+WRO+MPV+ILO+PDL+IOC+RUN+RLT> ;STANDARD .MASK
IFN USELESS, ITSMSK=ITSMSK+%PI<CLI+DWN+DBG+ATY>
DBGMSK=ITSMSK-<%PI<PAR+MPV+ILO>> ;DEBUGGING .MASK
.SEE INTMSK
ITSMS2==177777 ;STANDARD .MSK2
IFN JOBQIO, ITSMS2==ITSMS2+<377,,>
DBGMS2==ITSMS2 ;DEBUGGING .MSK2
.SEE INTMS2
DEFINE INTGRP HANDLER+PIRQC=0,IFPIR=0,DF1=ITSMSK-<%PI<PDL+PAR+WRO+MPV+ILO>>,DF2=ITSMS2
PIRQC
IFPIR
DF1
DF2
HANDLER
TERMIN
INTVEC: F←6+1,,INTPDL ;PDL FOR PUSHING INTERRUPT STUFF
;AC F IS SAVED ALONG WITH OTHER CRUD
INTGRP MEMERR,PIRQC=%PI<PAR+WRO+MPV+ILO>,DF1=ITSMSK-%PI<PDL> ;MEMORY AND OPCODE ERRORS
INTGRP PDLOV,PIRQC=%PI<PDL> ;PDL OVERFLOW
INTGRP IOCERR,PIRQC=%PI<IOC> ;I/O CHANNEL ERROR
IFN USELESS, INTGRP CLIINT,PIRQC=%PI<CLI> ;CLI INTERRUPT
IFN USELESS, INTGRP TTRINT,PIRQC=%PI<ATY> ;TTY RETURNED TO JOB
IFN USELESS, INTGRP SYSINT,PIRQC=%PI<DWN+DBG> ;SYS DOWN OR DEBUGGED
IFN JOBQIO, INTGRP JOBINT,IFPIR=[377,,] ;INFERIOR PROCEDURES
INTGRP CHNINT,IFPIR=177777 ;I/O CHANNEL INTERRUPTS
TTYDF1==.-2 .SEE UINT0
TTYDF2==.-1
IFN USELESS, INTGRP MARINT,PIRQC=%PI<MAR> ;MAR BREAK
INTGRP RUNCLOCK,PIRQC=%PI<RUN> ;RUNTIME ALARMCLOCK
INTGRP REALCLOCK,PIRQC=%PI<RLT> ;REAL TIME ALARMCLOCK
LINTVEC==.-INTVEC ;LENGTH OF INTERRUPT VECTOR
;;; NOTE THE EFFECT OF HAVING THE ALARMCLOCKS LAST:
;;; IOC AND CHANNEL INTERRUPT HAPPEN FIRST, BUT WHEN
;;; THE PION HAPPENS INSIDE UINT0 THE ALARMCLOCK GETS
;;; ITS TURN IMMEDIATELY. FURTHERMORE, THE REAL TIME
;;; CLOCK GETS SLIGHTLY HIGHER PRECEDENCE.
;;; IFN QIO
;;; WHEN THE INTERRUPT OCCURS, AC F HAS BEEN SAVED.
;;; BY CONVENTION AN INTERRUPT HANDLER GETS THE INTPDL POINTER IN F.
;;; ALSO BY CONVENTION, R IS EXCHANGED WITH THE FIRST WORD
;;; INTERRUPT BITS AND D IS EXCHANGED WITH THE SECOND WORD
;;; INTERRUPT BITS WHICH ARE ON THE INTPDL.
;;; STANDARD INTERRUPT EXIT
;;; WILL RESTORE FXP AND D+R+F, AND DISMISS THE INTERRUPT.
INTXIT: POP FXP,FXP
MOVE D,IPSWD2(F) ;D WAS EXCH'D WITH SECOND WORD INT BITS
MOVE R,IPSWD1(F) ;R WAS EXCH'D WITH FIRST WORD INT BITS
.CALL INTXT9 ;RETURN PC IS ON TOP OF INTPDL,
.VALUE ; AND ALSO THE OLD DEFER WORDS
INTXT9: SETZ
SIXBIT \DISMIS\ ;DISMISS INTERRUPT
5000,,F←6+1 ;POP AC F FIRST
400000,,INTPDL ;INTERRUPT STACK POINTER
;;; STANDARD LOSING INTERRUPT EXIT
;;; RESTORES FXP, AND D+R+F AS INTXIT DOES.
;;; ALSO EXPECTS A .LOSE ERROR CODE IN R.
INTLOS: POP FXP,FXP
MOVE D,IPSWD2(F)
INTLS1: EXCH R,IPSWD1(F)
.CALL INTLS9
.VALUE
INTLS9: SETZ
SIXBIT \DISMIS\ ;DISMISS INTERRUPT
5000,,F←6+1 ;POP AC FFIRST
,,INTPDL ;INTERRUPT STACK POINTER
,,IPSPC(F) ;NEW PC ;IN ORDER TO SPECIFY
,,IPSDF1(F) ;NEW .DF1 ; THE .LOSE CODE, ONE
,,IPSDF2(F) ;NEW .DF2 ; MUST MENTION ALL THIS TOO
400000,,IPSWD1(F) ;.LOSE ERROR CODE
.SEE PION
;;; ENABLES **ALL** INTERRUPTS.
.SEE PIOF
;;; DISABLES **ALL** INTERRUPTS.
.SEE INTON
;;; INITIALLY SETS UP INTERRUPT SYSTEM.
PINBL: .SPICLR,,XC-1 ;.PICLR <- -1
.SDF1,,R70 ;.DF1 <- 0
.SDF2,,R70 ;.DF2 <- 0
PIHOLD: .SPICLR,,R70 ;.PICLR <- 0
INTNBL: .SDF1,,R70 ;.DF1 <- 0
.SDF2,,R70 ;.DF2 <- 0
INTNMS: .SMASK,,INTMSK ;.MASK <- INTMSK
.SMSK2,,INTMS2 ;.MSK2 <- INTMS2
;;; IFN QIO
;;; MEMORY AND OPCODE ERRORS: PARITY, PURE, MPV, ILOP.
;;; ASSUME NO MORE THAN ONE HAPPENS AT A TIME.
MEMERR: MOVE F,INTPDL
MOVEM D,IPSWD2(F)
EXCH R,IPSWD1(F)
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
HRRZ D,IPSPC(F)
CAIN D,THIRTY+5 ;DDT DOES ≠X IN LOCATION 34
JRST $XLOSE
TLNE R,(%PI<PAR>) ;WAS IT A PARITY ERROR?
JRST PARERR
TLNE R,(%PI<WRO>) ;WRITE INTO READ-ONLY?
JRST PURPGI
TRNE R,%PI<ILO> ;ILLEGAL OPERATION?
JRST ILOPER
TRNN R,%PI<MPV> ;MEMORY PROTECT VIOLATION?
.VALUE ;NO??? WHAT HAPPENED???
CAIE D,UBD1 ;LET SPECPDL RESTORATION HAPPEN
JRST MPVERR ; EVEN IF ONE SLOT GOT CLOBBERED
AOS IPSPC(F) ;BUMP PC PAST OFFENDING INSTRUCTION
JRST INTXIT
MPVERR: SKIPA D,[UIMMPV]
PURERR: MOVEI D,UIMWRO
JRST MEMER5
ILOPER: SKIPA D,[UIMILO]
PARERR: MOVEI D,UIMPAR
MEMER5: HRRZ R,IPSPC(F) ;MACHINE ERROR! WHAT TO DO?
SKIPN VMERR ;IF USER SUPPLIED NO ERROR FUNCTION,
JRST MEMER7 ; CRAP OUT BACK TO DDT
MOVEI D,100000(D)
HRLI D,(R)
PUSHJ FXP,IWAIT
PUSHJ P,UINT
JRST INTXIT ;MAY RE-DO LOSING INSTR, BUT SO WHAT?
; THAT'S A FEATURE, NOT A BUG.
MEMER7: HRRZ R,MEMER8(D)
JRST INTLOS
MEMER8:
OFFSET -.
UIMPAR:: 1+.LZ %PIPAR
UIMILO:: 1+.LZ %PIILO
UIMWRO:: 1+.LZ %PIWRO
UIMMPV:: 1+.LZ %PIMPV
OFFSET 0
$XLOST: .VALUE [ASCIZ \:≠ YOUR ≠↔≠⊗X LOST ≠↔PROCEED⊗ \]
JRST THIRTY+5 ;LET THE ≠X RETURN CORRECTLY
$XLOSE: MOVEI R,$XLOST ;CAUSE INTERRUPT DURING AN ≠X
MOVEM R,IPSPC(F) ; TO GO TO $XLOST (CROCK)
JRST INTXIT
;;; IFN QIO
;;; I/O CHANNEL ERROR HANDLER
IOCERR: MOVE F,INTPDL
MOVEM D,IPSWD2(F)
MOVEM R,IPSWD1(F)
MOVE R,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,R
.SUSET [.RBCHN,,R]
SKIPN R
JRST IOCER8
.CALL SCSTAT
.LOSE 1400
LSH D,-33
HRRZ R,IPSPC(F)
MACROLOOP NIOCTR,ZZI,* ;ZZI MACROS DEFINE IOC TRAPS
SKIPL R
JRST IOCER8
HRRM R,IPSPC(F) ;CLOBBER RETURN PC
HLRZ R,R
CAIN R,400000+D ;WANT TO STICK IOC ERROR
MOVEI R,400000-IPSWD2(F) ; CODE INTO SPECIFIED AC,
CAIN R,400000+R ; BUT MUST BEWARE OF D AND R
MOVEI R,400000-IPSWD1(F)
MOVEM D,-400000(D)
JRST INTXIT
IOCER8: MOVEI R,1+.LZ %PIIOC
JRST INTLOS
;;; IFN QIO
; COMMENT FOR @ CHANGE
;;; INTERRUPT FROM I/O CHANNEL.
;;; PRESENTLY ONLY TWO KINDS ARE HANDLED:
;;; TTY INPUT: INTERRUPT CHAR TYPED.
;;; TTY OUTPUT: **MORE**.
CHNINT: MOVE F,INTPDL
EXCH D,IPSWD2(F) ;GET WORD TWO INTERRUPT BITS
MOVEM R,IPSWD1(F)
MOVE R,FXP ;FXP MAY BE IN A BAD STATE IF
SKIPE GCFXP ; WITHIN GC, SO RESTORE IT AND
MOVE FXP,GCFXP ; THEN PUSH ITS OLD VALUE
PUSH FXP,R ;REMEMBER, PDL OVERFLOW ISN'T DEFERRED NOW
PUSH FXP,D
CHNI1: JFFO D,.+1 ;FIND CHANNEL NUMBER
MOVNS R ; FOR SOME PENDING
ADDI R,43 ; INTERRUPT BIT
PUSH FXP,R ;SAVE CHANNEL NUMBER
SKIPE R ;CHANNEL 0 ??
SKIPN CHNTB(R) ;UNOPEN DEVICE ??
.VALUE
MOVEI D,1
LSH D,(R)
ANDCAM D,-1(FXP) ;CLEAR THE BIT
CHNI1H: .CALL SCSTAT ;GET STATUS FOR THE CHANNEL
.VALUE
ANDI D,77 ;GET ITS INTERNAL PHYSICAL DEVICE TYPE
SKIPE D
CAILE D,2
JRST CHNI5
HRRZ D,CHNTB(R)
MOVE D,TTSAR(D)
TLNE D,TTS<IO>
JRST CHNI5
.ITYIC R, ;TYPE 0 IS TTY INPUT
JRST CHNI8 ;TIMING ERROR OR SOMETHING - IGNORE
PUSH FXP,R ;SAVE INTERRUPT CHARACTER
PUSH FXP,TT ; AND ALSO TT
HRRZ TT,-2(FXP) ;FETCH CHANNEL NUMBER
HRRZ TT,CHNTB(TT)
HRRZ TT,TTSAR(TT)
JSP D,TTYICH ;GET BACK INTERRUPT FN IN R
POP FXP,TT
JUMPE R,CHNI2 ;NULL FUNCTION - IGNORE
MOVEI D,(R)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNN D,FX
JRST CHNI4
MOVE R,(R) ;"FUNCTION" IS A FIXNUM
MOVEI D,(R) ;IF EITHER OF THE META AND
ANDCM D,(FXP) ; CONTROL BITS ARE SET IN THE
MOVSS (FXP) ; "FUNCTION", INSIST THAT THE
ANDM R,(FXP) ; CORRESPONDING BITS APPEAR IN
MOVSS (FXP) ; THE CHARACTER TYPED. SIMILARLY,
IOR D,(FXP) ; THE SAME BITS SET IN THE LEFT HALF
TRNE D,%TX<MTA+CTL> ; MEAN THAT THOSE BITS MUST BE OFF.
JRST CHNI2
ANDI R,177
MOVEI D,TRUTH ;MOOOOBY SKIP CHAIN OF SYSTEM INTS
CAIN R,↑C ;↑C (SETQ ↑D NIL)
SETZM GCGAGV
CAIN R,↑D ;↑D (SETQ ↑D T)
HRRZM D,GCGAGV
CAIN R,↑G ;↑G (↑G) ;QUIT
JRST CN.G
CAIN R,↑R ;↑R (SETQ ↑R T)
HRRZM D,TAPWRT
CAIN R,↑T ;↑T (SETQ ↑R NIL)
SETZM TAPWRT
CAIN R,↑V ;↑V (SETQ ↑W NIL)
SETZM TTYOFF
CAIN R,↑W ;↑W (PROG2 (SETQ ↑W T)
JRST CN.W ; (CLEAR-OUTPUT T))
CAIN R,↑X ;↑X (ERROR 'QUIT) ;↑X QUIT
JRST CN.X
CAIN R,↑Z ;↑Z CRAP OUT TO DDT
JRST CN.Z
CHNI2: SUB FXP,R70+2
JRST CHNI9
;;; IFN QIO
CHNI4: POP FXP,D ;REAL LIVE USER INTERRUPT FUNCTION
TRO D,400000 ;2.9 => TTY INPUT INTERRUPT CHAR
CHNI4A: POP FXP,R
HRL D,CHNTB(R)
SKIPE UNREAL
JSP R,CHNI4C ;BARF! (NOINTERRUPT 'TTY) OR (NOINTERRUPT T)
PUSHJ FXP,IWAIT ;CALLS UISTAK AND SKIPS IF IN GC
PUSHJ P,UINT ;RUNS USER INTERRUPT
JRST CHNI9
CHNI5: HRRZ D,CHNTB(R) ;CHECK OUT FILE ARRAY
HRRZ D,TTSAR(D)
SKIPN FO.EOP(D) ;SKIP IF ENDPAGEFN
JRST CHNI8
MOVEI D,200000+<2*FO.EOP+1> ;2.8 => RANDOM FILE INTERRUPT
JRST CHNI4A ;**MORE** => ENDPAGEFN GETS RUN
CHNI8: SUB FXP,R70+1
CHNI9: SKIPE D,(FXP)
JRST CHNI1
CHNI9A: SUB FXP,R70+1 ;COME HERE FROM JOBI8
JRST INTXIT
;;; ROUTINE TO STACK UP INTERRUPT IN INTAR -- USED BY CHNINT, JOBINT, AND FNYINT
CHNI4C: MOVE F,UNREAR ;STACK UP INTERRUPT IN THE
CAIL F,LUNREAR ; NOINTERRUPT QUEUE
JRST TMDAMI ;OOPS! TOO MANY DAMN INTERRUPTS!
MOVE F,[400000+LUNREAR-1,,UNREAR+LUNREAR-2]
CHNI4H: POP F,1(F)
TLNE F,377777
JRST CHNI4H
MOVEM D,UNREAR+1
AOS UNREAR
HRRZ F,INTPDL
JRST 2(R)
;;; IFN QIO
; COMMENT FOR @ CHANGE
IFN JOBQIO,[
;;; INTERRUPT FROM INFERIOR PROCEDURE(S)
JOBINT: MOVE F,INTPDL
EXCH D,IPSWD2(F)
MOVEM R,IPSWD1(F)
MOVE R,FXP
SKIPE GCFXP ;IF IN GC, FXP MAY BE
MOVE FXP,GCFXP ; SCREWED UP
PUSH FXP,R
PUSH FXP,D ;WORD OF INTERRUPT BITS
JOBI1: JFFO D,.+1
MOVNS R ;-22 < R < -11
MOVSI D,1
LSH D,21(R)
ANDCAM D,(FXP) ;CLEAR BIT
SKIPN D,JOBTB+21(R)
.VALUE ;NO JOB ARRAY???
HRRZ R,TTSAR(D)
SKIPN J.INTF(R)
JRST JOBI8 ;NO INTERRUPT FUNCTION - IGNORE INTERRUPT
MOVSI D,(D)
TRO D,200000+<2*J.INTF+1>
SKIPGE UNREAL
JSP R,CHNI4C ;GORP! (NOINTERRUPT T)
PUSHJ FXP,IWAIT
PUSHJ P,UINT
JOBI8: SKIPE D,(FXP)
JRST JOBI1 ;MORE INFERIOR INTERRUPTS
JRST CHNI9A ;ALL DONE
] ;END OF IFN JOBINT
;;; IFN QIO
;;; TTSAR OF TTY INPUT FILE ARRAY IN TT.
;;; INPUT INTERRUPT CHARACTER IN R.
;;; RETURN ADDRESS IN D.
;;; RETURNS INTERRUPT FUNCTION IN R.
TTYICH: TRZ R,%TX<TOP+SFL+SFT+MTA> ;FOLD 12.-BIT CHAR
TRZN R,%TX<CTL> ; DOWN TO 7 IF NECESSARY
JRST TTYIC1
CAIE R,177
TRZ R,140
TTYIC1: ROT R,-1 ;CLEVER ARRAY ACCESS
ADDI TT,FB.BUF(R) ;INTERRUPT FNS ARE IN "BUFFER"
HLR R,(TT)
SKIPGE R
HRRZ R,(TT) ;SIGN BIT OF R GETS CLEARED
JRST (D)
;;; VARIOUS SYSTEM TTY INPUT CHAR INTERRUPT HANDLERS.
CN.W: HRRZM D,TTYOFF ;IMMEDIATE TTYOFF (↑W)
PUSH FXP,T
PUSH FXP,TT
HRRZ TT,V%TYO
MOVE TT,TTSAR(TT)
PUSHJ FXP,CLRO3 ;ALSO DO (CLEAR-OUTPUT T)
POP FXP,TT
POP FXP,T
JRST CHNI2
CN.Z: .CALL CKI2I ;***** CROCK *****
.VALUE
.VALUE [ASCIZ \:≠DDT≠
\]
JRST CHNI2
CTRLG: HRROI D,-3 ;↑G - SUBR 0
PIOF
JRST CN.G0
CN.X: SKIPA D,[-6] ;ERRSETABLE (↑X) QUIT
CN.G: HRROI D,-7 ;IMMEDIATE (↑G) QUIT
CN.G0: SKIPE UNREAL
JRST CN.G1
CN.G5: SETZM INTAR ;KILL ALL INTERRUPTS STACKED UP
HRREM D,INTFLG
PUSHJ FXP,IWAIT
PUSHJ P,CHECKI
JRST CHNI2
CN.G1: SETZM UNREAR ;KILL STACKED UNREAL INTERRUPTS
CAMN D,XC-3
JRST CN.G5 ;JUMP IF ↑G SUBR
EXCH D,UNRC.G ;ELSE STACK UP AN UNREAL
TRNE D,1 ; ↑G OR ↑X INTERRUPT
MOVEM D,UNRC.G
JRST CHNI2
;;; IFN QIO
;;; REAL TIME ALARMCLOCK
REALCLOCK:
MOVE F,INTPDL
MOVEM R,IPSWD1(F)
MOVSI R,400000 ;SHUT CLOCK BACK OFF
.REALT R,
MOVEI R,QTIME
JRST RCLOK1
;;; RUNTIME ALARMCLOCK
RUNCLOCK:
MOVE F,INTPDL
MOVEM R,IPSWD1(F)
MOVEI R,Q$RUNTIME
RCLOK1: MOVEM D,IPSWD2(F)
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
SKIPN VALARMCLOCK ;IGNORE IF THERE IS NO
JRST INTXIT ; ALARMCLOCK FUNCTION
MOVSI D,(R) ;TYPE 0, SUBTYPE 0 IS ALARMCLOCK
SKIPL UNREAL ;SKIP IF (NOINTERRUPT T)
JRST RCLOK2
MOVEM D,UNRRUN-Q$RUNTIME(R) ;STACK UP INTERRUPT
JRST INTXIT
IFN USELESS,[
FNYINT: MOVEM D,IPSWD2(F) ;COMMON HANDLER FOR FUNNY INTERRUPTS
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
MOVE R,(R)
SKIPN (R)
JRST INTXIT ;EXIT IF NO USER HANDLER
HLRZ D,R
SKIPGE UNREAL
JSP R,CHNI4C ;MUST STACK UP IF UNREAL
] ;END OF IFN USELESS
RCLOK2: PUSHJ FXP,IWAIT ;WILL STACK AND SKIP IF GC
PUSHJ P,UINT ;GIVE USER CLOCK INTERRUPT
JRST INTXIT
;;; IFN QIO
IFN USELESS,[
;;; CLI INTERRUPT HANDLER
CLIINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
JSP R,FNYINT
UIFCLI,,VCLI
;;; MAR BREAK
MARINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
MOVEI R,%PI<MAR>
ANDCAM R,INTMSK
.SUSET INTNMS
.SUSET [.SMARA,,R70]
MOVEI R,1+.LZ %PIMAR
SKIPN VMAR
JRST INTLS1 ;IN CASE (STATUS MAR) GETS LOUSED UP
JSP R,FNYINT
UIFMAR,,VMAR
;;; RETURN OF TTY TO THE JOB
TTRINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
JSP R,FNYINT
UIFTTR,,VTTR
;;; SYSTEM GOING DOWN OR BEING DEBUGGED
SYSINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
JSP R,FNYINT
UIFSYS,,VSYSD
] ;END OF IFN USELESS
;;; IFN QIO
;;; STACK UP A USER INTERRUPT WHICH MUST BE DELAYED.
;;; ARGUMENT IS IN D AS FOR UINT; IT IS SAVED IN THE INTAR QUEUE.
;;; ASSUMES FREE USE OF ACCUMULATOR R.
;;; PI INTERRUPTS MUST BE DISABLED!!!!
.SEE PIOF
YESIN1: POP P,UISTAK ;THIS IS A HORRIBLE CROCK
;UISTAK: 0
UISTK1: MOVE R,INTFLG ;IF WE ARE ABOUT TO QUIT ANYWAY,
AOJL R,@UISTAK ; THEN FORGET THE WHOLE THING
AOS R,INTAR
CAILE R,LINTAR
JRST TMDAMI ;TOO MANY DAMN INTERRUPTS
MOVE R,[400000+LINTAR-1,,INTAR+LINTAR-2]
UISTK2: POP R,1(R)
TLNE R,377777
JRST UISTK2
MOVSM D,INTAR+1
SETOM INTFLG
JRST @UISTAK
TMDAMI: SKIPN GCFXP ;TOO MANY DAMN INTERRUPTS
LERR EMS12
IRP X,,[P,FLP,FXP,SP]
MOVE X,GC!X
TERMIN
LERR EMS12
] ;END OF IFN QIO
IFE D10,[
IFE QIO,[
;;; PURE PAGE TRAP HANDLER
PURPGI: MOVEM A,INTSV ;TRIED TO WRITE INTO A PURE PAGE
HRRZ A,IPCLOK
CAIN A,STQPUR+1
JRST PPGI5
MACROLOOP NPURTR,ZZP,*, ;ZZP MACROS DEFINE WHAT PLACES HAVE HANDLERS
JUMPGE A,PPGI2
PPGI3: HRRM A,IPCLOK
JRST INTEX
PPGI2: MOVEI A,4 ;LOSE LOSE - A BAD ERROR
JRST PPGI4
PPGI5: EXCH A,INT ;REMEMBER WHICH VALUE CELL WE TRIED TO GRONK
MOVEM A,STQLUZ
MOVE A,[TIRPATE,,NIL]
MOVEM A,(SP)
MOVE A,STQLUZ
EXCH A,INT
JSR INTWAIT ;LET SPDL GET CAUGHT UP, IF LAMBDA OR SET BINDING
SKIPA T,STQLUZ ;ERROR HANDLER WANTS LOCATION IN T
JRST PPGI2 ;IN CASE INTWAIT SKIPS
PPGI6: HRRZI A,NILSETQ ;TRIED TO PUT A VALUE PROPERTY ON NIL
JRST PPGI3
; ENDCODE [PURPGI]
] ;END OF IFE QIO
IFN QIO,[
; PUTCODE [QIO PURPGI]\20+2*NPURTR,INT,GC
;;; PURE PAGE TRAP HANDLER
;;; COMES HERE WITH LOSING PC IN D.
.SEE MEMERR
PURPGI: CAIN D,STQPUR
JRST PPGI5
MACROLOOP NPURTR,ZZP,*, ;ZZP MACROS DEFINE WHAT PLACES HAVE HANDLERS
JUMPGE D,PURERR
PPGI3: HRRM D,IPSPC(F)
JRST INTXIT
PPGI5: MOVEM A,STQLUZ ;REMEMBER WHICH VALUE CELL WE TRIED TO GRONK
MOVE D,[TIRPATE,,NIL]
MOVEM D,(SP)
SKIPE GCFXP
.VALUE
AOS IPSPC(F) ;DON'T RETRY THE LOSING INSTRUCTION!
PUSHJ FXP,IWAIT ;LET SPDL GET CAUGHT UP
SKIPA T,STQLUZ ;ERROR HANDLER WANTS LOCATION IN T
JRST PURERR ;INTWAIT MAY SKIP
PPGI6: HRRZI D,NILSETQ ;TRIED TO PUT A VALUE PROPERTY ON NIL
JRST PPGI3
; ENDCODE [QIO PURPGI]
] ;END OF IFN QIO
] ;END OF IFE D10
SUBTTL USER INTERRUPT ROUTINES
;;; USER INTERRUPT TYPES FOR NEWIO
;;;
;;; FORM OF ARGUMENT TO UINT (ALSO STORED IN THIS FORM
;;; IN INTAR, ONLY WITH HALVES SWAPPED; WHY, I DON'T KNOW):
;;;
;;; 4.9-3.1 ARGUMENT FOR INTERRUPT FUNCTION
;;; 2.9 IF 1, SPECIFIES A TTY INPUT CHARACTER INTERRUPT.
;;; ARGUMENT IS TTY INPUT FILE ARRAY.
;;; 2.8-2.4 MUST BE ZERO.
;;; 2.3-1.1 CHARACTER WHICH CAUSED INTERRUPT, AS
;;; READ BY .ITYIC. THIS MAY BE A 12.-BIT
;;; CHARACTER, AND SO MAY HAVE TO BE FOLDED
;;; BEFORE SELECTING THE INTERRUPT FUNCTION.
;;; THIS IS PASSED AS THE SECOND ARGUMENT.
;;; 2.8 IF 1, SPECIFIES AN INTERRUPT RELATED TO A FILE
;;; ARRAY OR SIMILAR OBJECT, E.G. THE **MORE**
;;; INTERRUPT FOR TTY OUTPUT.
;;; ARGUMENT IS THE FILE ARRAY.
;;; 2.7-1.1 IS THE INDEX OF THE INTERRUPT FUNCTION
;;; WITHIN THE ARRAY, WHERE THE LOW BIT SPECIFIES
;;; LEFT OR RIGHT HALF AS USUAL.
;;; 2.7 IF 1, SPECIFIES A MACHINE ERROR.
;;; THE ARGUMENT IS THE LOCATION OF THE LOSS.
;;; BITS 1.9-1.1 SPECIFY THE NATURE OF THE ERROR.
UIMPAR==:0 ;ODDP ;PARITY ERROR
UIMILO==:1 ;EVAL ;ILLEGAL OPERATION
UIMWRO==:2 ;DEPOSIT ;WRITE INTO READ-ONLY MEMORY
UIMMPV==:3 ;EXAMINE ;MEMORY PROTECT VIOLATION
;;; IF 2.9-2.7 ARE ZERO, THEN:
;;; 2.2-2.1 TYPE OF INTERRUPT
;;; 1.9-1.1 SPECIFIC INTERRUPT
;;; CURRENT TYPES AND SPECIFIC INTERRUPTS ARE:
;;; 0 RANDOM ASYNCHRONOUS (DELAYED BY (NOINTERRUPT T))
;;; 0 ALARMCLOCK
UIFCLI==:1 ;CLI-MESSAGE ;USELESS
UIFMAR==:2 ;MAR-BREAK ;USELESS
UIFTTR==:3 ;TTY-RETURN ;USELESS
UIFSYS==:4 ;SYS-DEATH ;USELESS
IFE USELESS, NUINT0==:1 .SEE GCP6Q6
IFN USELESS, NUINT0==:5 .SEE GCP6Q6
;;; 1 RANDOM SYNCHRONOUS
;;; 0 AUTOLOAD
;;; 1 ERRSET FN
;;; 2 *RSET-TRAP
;;; 3 GC-DAEMON
;;; 4 GC-OVERFLOW
;;; 5 PDL-OVERFLOW
NUINT1==:6 .SEE GCP6Q6
;;; 2 ERINT (SYNCHRONOUS)
;;; 0 UNDF-FNCTN
;;; 1 UNBND-VRBL
;;; 2 WRNG-TYPE-ARG
;;; 3 UNSEEN-GO-TAG
;;; 4 WRNG-NO-ARGS
;;; 5 GC-LOSSAGE
;;; 6 FAIL-ACT
;;; 7 IO-LOSSAGE
NUINT2==:10 .SEE GCP6Q6
UINT:
Q% SKIPN @UINTTB(A) ;SERVICE USER INTERRUPT
Q% JRST FALSE ;WE DONT PUSHJ HERE FROM PI LEVEL, UNLESS WE KNOW
PUSHJ P,UINTPU ;THAT GC IS NOT IN PROGRESS [THUS WE HAVE A PDL]
SKIPN NOQUIT
SKIPE INHIBIT
JRST UINT2
SKIPGE INTFLG
JRST UINT3
PUSHJ P,UINT0
UINTEX: SKIPL (FXP) ;PEOPLE COME HERE TO UNDO UINTPU
JRST UINTX1
PION
UINTX1: SUB FXP,R70+1
Q$ POP FXP,R .SEE UINTPU
JRST CHECKI ;PDL-OVERFLOW MAY HAVE BEEN STACKED
Q% .SEE PDLHAK
Q$ .SEE PDLOV
UINT2: JSR UISTAK ;DELAY A USER INTERRUPT, SINCE INHIBIT SWITCH IS ON
JRST UINTEX
UINT3: HRRZ D,INTFLG ;CHECK INTERRUPT FLAG TO SEE THAT IS SAYS "QUIT"
CAIE D,-1 ;AND NOT SOME INCONCRUOUS USER PI
JRST CKI2
HHCTB: .VALUE
; LERR EMS11 ;HOW THE HELL CAN THIS BE?
UINTPU: ;PUSH PI STATE, THEN DISABLE
IFN ITS,[
Q$ PUSH FXP,R ;SAVE R FOR UISTAK, ETC.
PUSH FXP,T
.SUSET [.RPICLR,,T]
EXCH T,(FXP)
SKIPGE (FXP)
.SUSET PIHOLD
] ;END OF IFN ITS
10$ PUSH FXP,UPCOK
10$ SETZM UPCOK
POPJ P,
IFE QIO,[
YESIN1: POP P,UISTAK ;CROCK, CROCK, CROCK!!!
;UISTAK: 0
UISTK1: AOSGE INTFLG ;DONT WORRY, INTERRUPTS ARE SHUT OFF
JRST UINT4 ;USES QITD AND QITR, BUT NOT QITC
SETZM INTFLG
MOVEM D,QITD
MOVEM R,QITR ;STACK UP AN INTERRUPT IN THE DELAYED INTERRUPT ARRAY
AOS R,INTAR ;BECAUSE USER INTERRUPTS ARE NOT NOW ENABLED
CAILE R,LINTAR
LERR EMS12 ;TOO MANY INTERRUPTIONS
JRST UISTK3
UISTK2: MOVE D,INTAR(R)
MOVEM D,INTAR+1(R)
UISTK3: SOJG R,UISTK2
MOVSM A,INTAR+1
MOVE R,QITR
MOVE D,QITD
UINT4: SOS INTFLG
MOVEI A,0
JRST 2,@UISTAK
] ;END OF IFE QIO
IFE QIO,[
;;; SAVE WORLD - INCLUDES STATE OF PICL, VALUES OF ACCS 2 THRU 13
;;; AND MOST WRITABLE SYSTEM TEMPS. THEN RUN THE ASSOCIATED ROUTINE.
;;; INTERRUPTS MUST BE TURNED OFF WITH PIOF BEFORE COMING HERE.
YESINT: SKIPN NOQUIT
SKIPE INHIBIT
JRST YESIN1
UINT0: HRRZS (P)
SKIPGE UINTTB(A)
HRROS (P)
HRR A,@UINTTB(A) ;ARG IN LH, TABLE INDEX IN RH CONVERTED INTO INT FUN
PUSH P,A
UINT26: HLRZ A,P
CAIL A,LUINF
10% JRST UINT27
UINT42: HLRZ A,FXP
CAIL A,-<LSWS+6>
10$ JRST XPOV
.ELSE,[
JRST UINT43
UINT55: HLRZ A,SP
CAIL A,-4
JRST UINT56
] ;END OF .ELSE
PUSH FXP,UNREAL
SKIPGE -1(P)
SETOM UNREAL
ADD FXP,[LSWS+5,,LSWS+5]
PUSH P,[$UIFRAME]
PUSH P,FXP ;SAVE PDLS SO THAT IF FRETURN WANTS TO BREAK OUT
HRLM FLP,(P) ;OF A USER INTERRUPT, HE CAN DO SO CORRECTLY
PUSHJ FXP,SAV5M1
PUSH P,40 ;SAVE INTERPRETED ACS AND STUFF ON PDL TO GC PROTECT IT
LUINF==-<NACS-1>-1-2 ;LOCATION OF USER INTERRUPT FUNCTION ON PDL - WHERE A WENT
MOVEI A,-<LSWS+5>+1(FXP)
HRLI A,T
BLT A,-LSWS(FXP) ;SAVE NON-INTERPRETED ACS
MOVEI A,-<LSWS>+1(FXP)
HRLI A,SWS
BLT A,(FXP) ;SAVE SUPER-WRITABLE STUFF
JSP T,SPECBIND
0 NIL,TYIMAN ;EVIL VILLIANS, WE BIND TYI-MAN
0 NIL,TMBBC ; AND FORCE HIM TO DO OUR WILL!
0 NIL,LISAR
SETZM INTSV
SETZM PA4
IFN USELESS, SETZM TYOSW
SETZM INHIBIT
SETZM EOFRTN ;DO NOT SETZM CATRTN! GJS WANTS TO
SETOM RRDF ; THROW THROUGH USER INTERRUPTS
SETOM ERRSW
MOVEI A,LUINF+1(P)
MOVEM A,UIRTN
HLRZ A,LUINF(P)
HRRZS LUINF(P)
PION
CALLF 1,@LUINF(P) ;APPLY INTERRRUPT FUNCTION
;FALLS THROUGH
;FALLS IN
;;; IFE QIO
PIOF
MOVEM A,LUINF(P) ;SETUP FOR RETURN VALUE
PUSHJ P,UNBIND ;RESTORE TYIMAN ETC.
UINT0X: HRLI A,-<LSWS+5>+1(FXP) ;RESTORE WORLD
HRRI A,T
BLT A,T+4
HRLI A,-<LSWS>+1(FXP)
HRRI A,SWS
BLT A,SWS+LSWS-1
SUB FXP,[LSWS+5,,LSWS+5]
POP P,40
PUSHJ FXP,RST5M1
SUB P,R70+2 ;KNOCK OFF PDLS AND UIFRAME MARKER
POP FXP,A ;OLD STATE OF UNREAL
SKIPL -1(P) ;IF INTERRUPT TABLE DIDN'T HAVE BIT 4.9
JRST POPAJ ; ON, MUSTN'T ATTEMPT TO RESTORE UNREAL
EXCH A,UNREAL ;WELL, WE WANT TO RESTORE IT. WAS IT ON
JUMPE A,POPAJ ; JUST NOW? IF NOT, RETURN.
SKIPE UNREAL ;DID WE JUST TURN IT OFF BY RESTORING IT?
JRST UINT0Z ;NO, IT'S STILL ON - RETURN.
UINT0N: HRRZ A,-1(P) ;IS THE CHECKU ROUTINE ITSELF CALLING ME?
CAIL A,ENOINT ; DON'T WANT TO GET STUCK IN INFINITELY
JRST UINT0Q ; RECURSIVE CALLS.
CAIL A,NOINTERRUPT
JRST POPAJ
UINT0Q: PUSH FXP,F ;WELL, WE NEED TO RUN ANY DELAYED INTERRUPTS
SKIPE UNREAL
JRST UINT0Y
PUSHJ P,CHECKQ ;HACKISH ENTRY INTO CHECKU
UINT0V: POP FXP,F
JRST POPAJ
UINT0Y: PUSHJ P,CHECKZ ;HACKISH ENTRY INTO CHECKU
JRST UINT0V
UINT0Z: SKIPG UNREAL
JRST POPAJ
JUMPG A,POPAJ
JRST UINT0N
IFN ITS,[
UINT27: MOVE A,[LUINF,,P]
JSR PDLHAK
JRST UINT26
UINT43: MOVE A,[LSWS+6,,FXP]
JSR PDLHAK
JRST UINT42
UINT56: MOVE A,[4,,SP]
JSR PDLHAK
JRST UINT55
] ;END OF IFN ITS
] ;END OF IFE QIO
IFN QIO,[
;;; SAVE THE WORLD FOR A USER INTERRUPT, INVOKE IT, AND RESTORE.
;;;
;;; SAVED QUANTITIES INCLUDE ALL ACCUMULATORS, THE PDL POINTERS
;;; (FOR FRETURN), AND THE SUPER-WRITABLE STUFF (TEMPORARIES IN
;;; LOW CORE USED BY INTERRUPTABLE FUNCTIONS).
;;; MANY GLOBAL SWITCHES ARE BOUND AND RESET.
;;; FOR ASYNCHRONOUS USER INTERRUPTS, THE (NOINTERRUPT T) STATE
;;; MAY BE ENTERED; THE PREVIOUS NOINTERRUPT STATE IS SAVED.
;;; MUST NOT COME HERE WITHOUT FIRST USING THE IWAIT
;;; ROUTINE TO DECIDE WHETHER OR NOT WE ARE IN GC.
;;; ALSO MUST CHECK THE NOINTERRUPT SWITCH BEFORE COMING HERE
;;; IF THAT IS RELEVANT TO THE PARTICULAR USER INTERRUPT.
;;; INTERRUPTS MUST BE TURNED OFF WITH PIOF BEFORE COMING HERE.
;;; THE WORD DESCRIBING THE USER INTERRUPT MUST BE IN D.
YESINT: SKIPN NOQUIT
SKIPE INHIBIT
JRST YESIN1
UINT0: .SUSET [.SDF1,,TTYDF1] ;MUST ALLOW PDL OVERFLOW TO
.SUSET [.SDF2,,TTYDF2] ; GO THROUGH, BUT NO OTHERS.
.SUSET PINBL ; ALSO LET MPV GO THROUGH.
HRRZS (P) ;WILL HRROS IF ASYNCHRONOUS
PUSHJ P,SAVX5 ;SAVE NUMERIC ACS
PUSH FXP,UNREAL
MOVSI R,-LSWS
PUSH FXP,SWS(R)
AOBJN R,.-1
JSP T,SPECBIND ;MUST SPECBIND LISAR
LISAR
SETZM PA4
IFN USELESS, SETZM TYOSW
SETZM INHIBIT
SETZM EOFRTN ;DO NOT SETZM CATRTN! GJS WANTS
SETZM BFPRDP ; TO THROW OUT OF USER INTERRUPTS
SETOM ERRSW
MOVE T,[-LINTPDL,,INTPDL]
MOVEM T,INTPDL
REPEAT 3, PUSH FXP,R70 ;RANDOM SLOTS FOR NUMERIC ARGS;
; ; ALSO 4.9 OF TOP ONE => RETURN VALUE MATTERS
UIXPUSH==:5+1+LSWS+3 ;AMOUNT OF STUFF PUSHED ON FXP
UISWS==:-<LSWS+3>+1 ;WHERE SWS STARTS WHEN SAVED ON FXP
UISAVT==:UISWS-6 ;WHERE ACCUMULATOR T GETS SAVED
PUSH P,[$UIFRAME] ;FRAME MARKER AND PDLS SAVED
PUSH P,FXP ; SO THAT THROW AND FRETURN WIN
HRLM FLP,(P) .SEE UIBRK
PUSHJ FXP,SAV5 ;SAVE ARGUMENT ACS AND 40 ON
PUSH P,40 ; REGPDL FOR GC PROTECTION
UIFRM==-2-NACS ;LOCATION OF FRAME ON REGPDL
UISAVA==UIFRM+2 ;LOCATION OF AC A ON REGPDL
MOVEI A,UIFRM(P)
MOVEM A,UIRTN
MOVSI AR2A,(CALLF 1,)
HLRZ A,D ;GET FIRST ARG FOR INTERRUPT FN
TRZN D,400000 ;DECODE INTERRUPT TYPE
JRST UINT30
HRRZM D,(FXP) ;TTY INPUT INTERRUPT CHAR
MOVEI R,(D)
MOVE TT,TTSAR(A)
JSP D,TTYICH ;FETCH INTERRUPT FN
MOVSI AR2A,(CALLF 2,)
HRRI AR2A,(R)
MOVEI B,(FXP) ;SECOND ARG IS CHARACTER
JRST UINT31
;;; IFN QIO
UINT30: TRZN D,200000
JRST UINT32
MOVEI TT,(D) ;RANDOM FILE INTERRRUPT
ROT TT,-1
HRR AR2A,@TTSAR(A) ;FETCH INTERRUPT FUNCTION
SKIPL TT
HLR AR2A,@TTSAR(A)
UINT31: HRROS UIFRM-1(P) ;ASYNCHRONOUS INTERRUPT
JRST UINT40
UINT32: TRZN D,100000
JRST UINT33
HRRZM A,-1(FXP)
MOVEI A,QODDP(D) ;MACHINE ERROR
MOVEI B,(FXP)
MOVEI C,-1(FXP)
MOVEI AR1,-2(FXP)
MOVSI AR2A,(CALLF 4,)
HRR AR2A,VMERR
JRST UINT40
UINT33: LDB TT,[110200,,D] ;BITS 2.2-2.1 ARE CLASS
ANDI D,777 ;1.9-1.1 ARE SUBTYPE
XCT UINT90(TT) ;FETCH INTERRUPT FUNCTION
XCT UINT91(TT) ;SPECIAL HACKS
UINT40: SKIPGE UIFRM-1(P)
SETOM UNREAL
PION ;***** ENABLE INTERRUPTS *****
XCT AR2A ;APPLY INTERRUPT FUNCTION
HRRZ T,UIFRM+1(P)
CAIE T,(FXP)
PUSHJ P,UINT45
HLRZ T,UIFRM+1(P)
CAIE T,(FLP)
PUSHJ P,UINT46
PIOF ;***** DISABLE INTERRUPTS *****
SKIPGE (FXP) ;IF RETURN VALUE MATTERS
MOVEM A,UISAVA(P) ; SAVE IT FOR RETURN
PUSHJ P,UNBIND ;RESTORE LISAR, ETC.
UINT0X: HRLI R,UISWS(FXP)
HRRI R,SWS
BLT R,SWS+LSWS-1 ;RESTORE SUPER-WRITABLE STUFF
SUB FXP,[-UISWS+1,,-UISWS+1]
POP P,40
PUSHJ FXP,RST5M1
POP P,-2(P) ;KNOCK OFF PDLS AND UIFRAME, SAVING
SUB P,R70+1 ; SAVED CONTENTS OF A FOR POPAJ BELOW
POP FXP,D ;OLD STATE OF UNREAL
SKIPL -1(P) ;IF INTERRUPT WASN'T ASYNCHRONOUS,
JRST UINT88 ; MUSTN'T ATTEMPT TO RESTORE UNREAL
EXCH D,UNREAL ;WELL, WE WANT TO RESTORE IT. WAS IT ON
JUMPE D,UINT88 ; JUST NOW? IF NOT, RETURN.
SKIPE A,UNREAL ;DID WE JUST TURN IT OFF BY RESTORING IT?
JRST UINT0Z ;NO, IT'S STILL ON - RETURN.
UINT0N: HRRZ T,-1(P) ;IS THE CHECKU ROUTINE ITSELF CALLING ME?
CAIGE T,ENOINT ; DON'T WANT TO GET STUCK IN INFINITELY
CAIGE T,NOINTERRUPT ; RECURSIVE CALLS
PUSHJ P,CHECKQ ;HACKISH ENTRY INTO CHECKU
JRST UINT88
UINT0Z: SKIPLE UNREAL
JUMPLE D,UINT0N
UINT88: PUSHJ P,RSTX5
10% .SUSET PINBL
JRST POPAJ
Q$ EUINT0==. .SEE PDLOV ;END OF UINT0
UINT45: SKIPA B,[QFIXNUM]
UINT46: MOVEI B,QFLONUM
EXCH A,B
PUSHJ P,UINT49
EXCH A,B
POPJ P,
UINT49: FAC [PDL OUT OF PHASE IN USER INTERRUPT (SYSTEM ERROR)!]
UINT90: HRR AR2A,VALARMCLOCK(D) ;ALARMCLOCK SERIES
HRR AR2A,VAUTFN(D) ;RANDOM SYNCHRONOUS
HRR AR2A,VUDF(D) ;ERINT SERIES
.VALUE ;??
UINT91: HRROS UIFRM-1(P) ;ALARMCLOCK (ASYNCHRONOUS)
JFCL ;RANDOM SYNCHRONOUS
SETOM (FXP) ;ERINT (VALUE MATTERS)
.VALUE ;??
] ;END OF IFN QIO
CKI0: PUSH FXP,D
HRRZ D,INTFLG
CAIN D,-1
JRST CKI1 ;DELAYED USER INTERRUPT
PIOF
CKI2: SETZM UNREAR
CKI2A: SETZM UNRC.G ;CHECKU JOINS IN AT THIS POINT
SETZM INTFLG ; RESET TTY NO RESET
TRNE D,4 ;↑X -6 -2
JRST CKI3 ;↑G -7 -3
IFN ITS,[
Q% .RESET TYIC,
Q% .RESET TYOC,
IFN QIO,[
PUSH FXP,D
MOVEI F,LCHNTB-1 ;RESET ALL TTY FILES
CKI2F: SKIPN AR1,CHNTB(F)
JRST CKI2F1
MOVE TT,TTSAR(AR1)
TLNN TT,TTS<TY>
JRST CKI2F1
MOVEI T,CLRI3
TLNE TT,TTS<IO>
MOVEI T,CLRO3
PUSHJ FXP,(T)
CKI2F1: SOJG F,CKI2F
POP FXP,D
] ;END OF IFN QIO
] ;END OF IFN ITS
10$ CLRBFO
10$ CLRBFI
Q% SETZM PBFTY
Q% SETZM RDTYBF
CKI3:
IFN ITS,[
.SUSET [.RDF1,,A]
JUMPE A,CKI3B
.SUSET [.SAMASK,,A]
.SUSET [.SDF1,,R70]
] ;END OF IFN ITS
CKI3B: TRNN D,2
SKIPE PSYMF
RQITR: LERR [SIXBIT \QUIT!\] ;SO ERROR OUT FOR ↑X
MOVE P,C2 ;DRASTIC ACTION FOR ↑G
MOVE A,VERRLIST
MOVEM A,VIQUOTIENT
JSP A,ERINI0
IFN QIO*USELESS*ITS,[
MOVE T,INTMSK
TRNN T,%PI<MAR>
JRST CKI4A
.SUSET [.RMARA,,SAVMAR]
.SUSET [.SMARA,,R70] ;AVOID TRIPPING THE MAR DURING THE ERRPOP
CKI4A:
] ;END OF IFN QIO*USELESS*ITS
PUSHJ P,ERRPOP
IFN QIO*USELESS*ITS,[
TRNE T,%PI<MAR> ;ERRPOP PRESERVES T
.SUSET [.SMARA,,SAVMAR]
] ;END OF IFN QIO*USELESS*ITS
SETZM TTYOFF
STRT 17,@RQITR
JRST LSPRT1 ;WILL PION WITHIN ERINIT
CKI1:
Q% POP FXP,D ;RETURN TO SERVICE THE DELAYED INTERRUPT
SKIPE INHIBIT ;BUT NO SERVICE WHEN INHIBIT = -1
Q% POPJ P,
Q$ JRST POPXDJ
PUSHJ P,UINTPU
SETZM INTFLG
PUSH P,A
PUSH P,A
HLLOS INHIBIT
SKIPG A,INTAR
LERR EMS13 ;LOST USER INTERRUPT
CKI1A:
Q% MOVS A,INTAR(A)
Q% MOVSM A,(P) ;FOR GC PROTECTION
Q$ MOVS D,INTAR(A)
Q$ MOVSM D,(P)
SOS INTAR ;CYCLE THROUGH THE DELAYED INTERRUPTS
PUSHJ P,UINT0
SKIPLE A,INTAR
JRST CKI1A
SUB P,R70+1
POP P,A
SETZM INTFLG
SETZM INHIBIT
Q% JRST UINTEX
Q$ PUSHJ P,UINTEX
Q$ JRST POPXDJ
IFN QIO,[
CKI2I: SETZ ;EVENTUALLY FLUSH THIS
SIXBIT \RESET\
400000,,TTYIF2+F.CHAN
] ;END OF IFN QIO
IFE QIO,[
SUBTTL OLD I/O CONTROL CHARACTER ROUTINES
;CNTROL: 0
CNTRL1: CAIG A,36 ;NO INTERRUPT CHAR USABLE WITH ASCII > 036
XCT CNTBL(A)
JRST 2,@CNTROL
HRLI A,TRUTH ;SKIPS => WANTS T IN VALUE CELL
HLRZM A,@CNTBL(A)
JRST 2,@CNTROL
;;; ********** TABLE OF CONTROL CHAR ACTIONS **********
CNTBL: JRST CN.AT ;↑@
JRST CN.A ;↑A
10% SKIPA LPTON ;↑B
10$ JFCL ;↑B
SETZM GCGAGV ;↑C
SKIPA GCGAGV ;↑D
IFE D10, JRST CN.E ;↑E
IFN D10, JFCL
IFN MOBIOF, JRST CN.F ;↑F
IFE MOBIOF, JFCL
JRST CN.G ;↑G
JRST CN.H ;↑H
JFCL ;UNUSED CONTROL CHARACTERS, ETC.
REPEAT 4, JFCL ;↑J-↑M
IFN MOBIOF,[
SKIPA DISPON ;↑N
JRST CN.O ;↑O
] ;END OF IFN MOBIOF
IFE MOBIOF, REPEAT 2, JFCL
JFCL ;↑P
SKIPA TAPRED ;↑Q
SKIPA TAPWRT ;↑R
SETZM TAPRED ;↑S
SETZM TAPWRT ;↑T
SETOM PAUSFL ;↑U
SETZM TTYOFF ;↑V
JRST CN.W
JRST CN.X ;↑X
IFN MOBIOF, JRST CN.Y ;↑Y
IFE MOBIOF, JFCL
JRST CN.Z ;↑Z
JFCL ;ALT-MODE NOT MADE INTERRUPT CHAR
JRST CN.34 ;↑\
JRST CN.34 ;[ ;↑]
JRST CN.34 ;↑↑
IFN .-CNTBL-37, WARN [CNTBL LOSSAGE]
;;; IFE QIO,
IFN ITS,[
CN.E: .CLOSE LPTC,
SETZM LPTON
SETZM LPTOPD
JRST 2,@CNTROL
] ;END OF IFN ITS
IFN MOBIOF,[
CN.O: JSR CLZDIS
JRST 2,@CNTROL
] ;END OF IFN MOBIOF
CN.W: HRLI A,TRUTH
HLRZM A,TTYOFF
10% .RESET TYOC, ;RESET TTY OUTPUT CHANNEL
10$ CLRBFO
10X WARN [TTY OUTPUT CLEAR IN TENEX]
JRST 2,@CNTROL
CTRLG: PIOF ;↑G - SUBR 0
MOVE A,[-3,,-3]
JRST CN.G0
CN.X: SKIPA A,[-6,,-2] ;ERRSETABLE (↑X) QUIT
CN.G: MOVE A,[-7,,-3] ;IMMEDIATE (↑G) QUIT
CN.G0: SKIPE UNREAL
JRST CN.G1
SETZM INTAR ;KILL ALL INTERRUPTS STACKED UP
HRREM A,INTFLG
HRR A,CNTROL ;IF CALL CAME FROM IOC, THEN DONT
TRC A,IOC2 ;WANT TO DO A RESET ON THE TYI CHANNEL
TRNE A,-1
CN.G2: HLREM A,INTFLG
JSR INTWAIT
PUSHJ P,CHECKI
JRST 2,@CNTROL
CN.G1: SETZM UNREAR
MOVEM R,QITR
HRRZ R,CNTROL
CAME A,[-3,,-3]
CAIN R,IOC2
JRST CN.G3
MOVE R,UNRC.G
CAME R,XC-3
HRREM A,UNRC.G
MOVE R,QITR
JRST 2,@CNTROL
CN.G3: MOVE R,QITR
JRST CN.G2
;;; IFE QIO
CN.A: HRLI A,TRUTH
HLRZM A,SIGNAL
TLZA A,-1 ;WHEN ↑A HAPPENS, AC A HAS 1 IN IT, AND ↑A INT NO. IS 2
CN.34: SUBI A,34-14.+1 ;CNTRL KEYS 34-36 ARE INT NOS. 14. TO 16.
AOJA A,UINT1
Q% CN.H: ;CONTROL-H BREAK
Q$ CN.B: ;CONTROL-B BREAK
MOVEI A,1 ;CURRENTLY, ALL CONTROL-KEY INTERRUPTS HAVE NIL AS ARG
UINT1:
CN.AT: SKIPN @UINTTB(A) ;FOR ↑@, A MUST HAVE HAD ZERO IN IT
JRST 2,@CNTROL
SKIPE UNREAL
JRST UINT1Q
Q% SETOM PAUSFL
UINT1R: JSR INTWAIT
JRST UINT1A ;NO SKIP MEANS RUNNING INTERRUPT NOW IS OK
INTW3: JRST 2,@CNTROL ;OTHERWISE, A USER PI HAS BEEN STACKED UP
;[UNLESS THERE IS A QUIT SIGNAL PENDING]
UINT1A: PUSH P,CNTROL
10% PUSH P,INT ;INT CONTAINS WHAT WAS IN A UPON ENTRY
10% PUSH P,CPOP1J ;TO INTERRUPT - THUS IS NOW GC PROTECTED
10$ PUSHJ P,UPCHK
10X WARN [TENEX USER INTERRUPT]
JRST UINT
UINT1Q: MOVEM R,QITR
MOVEI R,(A)
CAIN R,3 ;ALARMCLOCK
JRST UINT1S
Q% HRRZ R,CNTROL
Q% CAIN R,IOC2
Q% JRST UINT1S
MOVEM D,QITD
AOS R,UNREAR
CAIG R,LUNREAR
JRST UINT1U
SOS UNREAR
LERR EMS12 ;TOO MANY INTERRUPTIONS
UINT1T: MOVE D,UNREAR(R)
MOVEM D,UNREAR+1(R)
UINT1U: SOJG R,UINT1T
MOVEM A,UNREAR+1
MOVE D,QITD
MOVE R,QITR
JRST 2,@CNTROL
UINT1S: MOVE R,QITR
JRST UINT1R
] ;END OF IFE QIO
SUBTTL UUOH HANDLER (INCLUDING STRT)
;UUOH: 0 ;UUO HANDLER
UUOH0: MOVEM T,UUTSV
LDB T,[331100,,40]
CAIL T,CALL←-33
JRST UUOH0B ;PROBABLY A LISP "CALL" UUO
UUOH2: CAILE T,UUOMAX
SETZ T,
JRST @UUOH2A(T)
UUOH2A: ERRBAD ;0 IS ILGL, ILGL, ILGL
ERROR1 ;LERR ;UNCORRECTABLE LISP ERROR
UUOACL ;ACALL ;KLUDGE FOR NCALLING ARRAYS
UUOAJC ;AJCALL ;JRST VERSION OF ACALL
ERROR1 ;LER3 ;LERR, BUT ALSO PRINT ACCUMULATOR A
ERROR5 ;ERINT ;CORRECTABLE ERROR WITH SIXBIT MSG
POF1 ;PP Z$X ;PRINT OUT Z FROM DDT
STRTOUT ;STRT ;SIXBIT STRING TYPE OUT
ERROR5 ;SERINT ;CORRECTABLE ERROR WITH S-EXP MSG
TOF1 ;TP Z$X ;TYPEP PRINTOUT OF Z FROM DDT
ERRIOJ ;IOJRST ;HAIRY FROB TO GET I/O ERROR MSGS
Q% ERRIOJ==:ERRBAD ;IOJRST IS FOR NEWIO ONLY
IFN .-UUOH2A-1-UUOMAX, WARN [UUOH2A OUT OF PHASE]
UUOACL: PUSH P,UUOH
BAKPRO
UUOAJC: MOVE T,@40 .SEE ASAR
TLNE T,AS<FX+FL>
AOJA T,.+2 ;FOR NUMBER ARRAYS, ENTER AT HEADER+1
PUSH P,[UUONVL] ;FOR OTHER ARRAYS, USE NUMVAL CHECK ROUTINE
XCTPRO
EXCH T,UUTSV
SPECPRO INTACT
JRST @UUTSV
NOPRO
;;; DISPATCH ON "CALL" TYPE UUO, TRAPPING TO INTERPRETER IF NECESSARY
UUOH0B: CAILE T,NJCALF←-33
JRST UUOH2
MOVEM TT,UUTTSV
MOVEM R,UURSV
LDB TT,[270400,,40]
CAIG TT,15 ;LISP "CALL" TYPE UUOS
TDZA R,R
MOVEI R,-15(TT)
HRRZ T,40
UUOH0A: MOVEM T,UUOFN
TLZ T,-1
MOVEI TT,(T)
LSH TT,-SEGLOG
SKIPGE TT,ST(TT)
JRST @UUNAF(R)
TLNN TT,SY
JRST UUOH0C
TLZ R,700000 ;400000 => AUTOLOAD, 200000 => MACRO, 100000 => ALREADY DID AUTOLOAD
UUOH1: HRRZ T,(T)
JUMPE T,UUOH1A
HLRZ TT,(T)
HRRZ T,(T)
CAIL TT,QARRAY
CAILE TT,QAUTOLOAD
JRST UUOH1
2DIF JRST @(TT),UUOTRT,QARRAY
UUOH0C: TLNN TT,SA
JRST UUOH3A
HRRZ TT,ASAR(T) ;HANDLE CASE OF A SAR EFFICIENTLY
CAIN TT,ADEAD
JRST UUOH3A
MOVSI T,(T)
HRRI T,T
JRST @UUAT(R)
UUOH1A: JUMPL R,UUALT1
TLNE R,200000
JRST UUOMER
PUSH P,A
PUSH P,B
SKIPGE A,UUOFN
JRST UUOUER
HLRZ T,(A)
HRRO T,@(T)
UUOH3B: POP P,B
POP P,A
CAIE T,QUNBOUND
JRST UUOH0A
JRST UUOH3A
;;UUO TRANSFER TABLE, ONCE FUNCTION TYPE IS KNOWN
UUOTRT:
IRPS LL,X,[A+S+FS+L+E+FE+MC-AL-]
IFSE X,+, @UU!LL!T(R)
IFSE X,-, UU!LL!T
TERMIN
;;; MOBY DISPATCH TABLE FOR DECODING UUO CALL TYPES!
;;; R=0 => COMPILED ROUTINE CALLING A SUBR TYPE
;;; R=1 => COMPILED ROUTINE CALLING A LSUBR TYPE
;;; R=2 => COMPILED ROUTINE CALLING A FSUBR TYPE
UUAT: UUOARR ;CALLING SUBR - IT'S AN ARRAY **WIN**
UUOS1A ;CALLING LSUBR - IT'S AN ARRAY
UUOS2A ;CALLING FSUBR - IT'S AN ARRAY
UUST: UUOS0 ;CALLING SUBR - IT'S A SUBR **WIN**
UUOS1 ;CALLING LSUBR - IT'S A SUBR
UUOS2 ;CALLING FSUBR - IT'S A SUBR
UUFST: UUOS10 ;CALLING SUBR - IT'S AN FSUBR
UUOS11 ;CALLING LSUBR - IT'S AN FSUBR
UUOSBR ;CALLING FSUBR - IT'S AN FSUBR **WIN**
UULT: UUOS7 ;CALLING SUBR - IT'S AN LSUBR
UUOLSB ;CALLING LSUBR - IT'S AN LSUBR **WIN**
UUOS9 ;CALLING FSUBR - IT'S AN LSUBR
UUET: UUOEXP ;CALLING SUBR - IT'S AN EXPR
UUOS5 ;CALLING LSUBR - IT'S AN EXPR
UUOS6 ;CALLING FSUBR - IT'S AN EXPR
UUFET: UUOS3 ;CALLING SUBR - IT'S A FEXPR
UUOS4 ;CALLING LSUBR - IT'S A FEXPR
UUOEX2 ;CALLING FSUBR - IT'S A FEXPR
UUNAF: UUOS ;CALLING SUBR - IT'S A NONATOMICFUN
UUL2N ;CALLING LSUBR - IT'S A NONATOMICFUN
UUF2N ;CALLING FSUBR - IT'S A NONATOMICFUN
UUALT: HRRZM T,UUALT9 ;FOUND AN AUTOLOAD PROPERTY
TLOA R,400000
UUMCT: TLO R,200000 ;MACROS ARE IGNORED, SORT OF
JRST UUOH1
UUALT1: TLOE R,100000 ;CALLING ANYTHING - IT'S AN AUTOLOAD
JRST UUOH3C ;LOSE IF JUST DID AN AUTOLOAD ALREADY
PUSH P,A
HLRZ A,@UUALT9 ;OTHERWISE AUTOLOAD THE FUNCTION
MOVE T,UUOFN
PUSHJ P,AUTOLOAD ;BETTER SAVE R, BY GEORGE!
POP P,A
MOVE T,UUOFN
JRST UUOH1 ;NOW TRY IT AGAIN
;;; MAY CALL UUOBNC AND UUOBAK ONLY WHEN *RSET IS KNOWN
;;; TO BE NON-NIL - AVOIDS CERTAIN TIMING ERRORS.
UUOBNC: POP P,UUOBKG ;UUOBKG WITH NO CPOPJ
HRROS UUOBKG ;FOR UUO GUYS THAT CALL IAPPLY,
JRST UUOBK0 ; WHICH ITSELF SETS UP A CPOPJ
UUOBAK: POP P,UUOBKG ;WATCH THIS CROCK!
JRST UUOBK7
;;;UUOBKG: 0
UUBKG1: SKIPN V.RSET ;CHECK TO SEE WHETHER IN *RSET MODE
JRST @UUOBKG ;SAVES ALL ACS; T HAS -<# OF ARGS>
UUOBK7: HRRZS UUOBKG
UUOBK0: SKIPE NIL
PUSHJ P,NILBAD
PUSH FXP,TT ;PDLS MUST BE AS FRETURN WOULD WANT
PUSH FXP,R ; TO RESTORE THEM TO
JUMPGE T,UUOBK1 ;IF T>0, THEN ASSUME 0, AND THE
JSP TT,ARGP0 ; ARGS WILL BE FILLED IN LATER
MOVNI TT,(T)
SKIPGE A
SETZ TT,
HRLM TT,(P)
JRST UUOBK8
UUOBK1: PUSH P,R70
UUOBK8: MOVEI TT,-2(FXP)
HRLI TT,(FLP)
PUSH P,TT
HRRZ TT,40
HRLI TT,(SP)
PUSH P,TT
JUMPLE T,UUOBK5
PUSH P,R70
JRST UUOBK6
UUOBK5: PUSH P,[$APPLYFRAME]
UUOBK6: MOVS R,40
HRRI R,CPOPJ
SKIPL UUOBKG ;MAYBE DON'T WANT THE CPOPJ
PUSH P,R
HRRZS UUOBKG
POP FXP,R
POP FXP,TT
JRST @UUOBKG
UUOSBR: HLRZ T,(T) ;*** FSUBR CALLED LIKE FSUBR
MOVEM P,UUPSV
MOVNI R,1
TLOA A,400000
UUOSB2: MOVEI R,1 ;R>0 SAYS DON'T DO FRAME HACKERY
UUOSB3: MOVE TT,40 ;OTHERWISE R HAS -<# OF ARGS>
UUOSB5: TLO T,(PUSHJ P,)
TLNE TT,(1←33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL
TLCA T,(JRST#<PUSHJ P,>)
PUSH P,UUOH
UUOSB6: JUMPG R,UUOSB7
EXCH T,R
JSR UUOBKG
EXCH T,R
UUOSB7: TLZ A,-1
TLNE TT,(20←33) ;THE NUMERIC CALL BIT. SEE DEFINITION OF NCALL
AOS T ;FOR NCALL, ENTER AT ENTRY+1
SKIPN VNOUUO
TLNE TT,(2←33) ;THE NO-CLOBBER BIT. SEE DEFINITION OF CALLF
JRST UUOXT0
SOS TT,UUOH
UUOSB4: LDB R,[331100,,(TT)]
CAIN R,XCT←-33
JRST UUOXCT ;MAKE XCT OF UUO WORK
MOVEM T,(TT)
UUOXT0: TLNN T,(34←33) ;CAUSE EXIT TO INDIRECT THRU ACALL
TLO T,(@)
UUOXIT: EXCH T,UUTSV
UUOXT1: MOVE TT,UUTTSV
MOVE R,UURSV
JRST @UUTSV
UUOXCT: LDB R,[220400,,(TT)] ;GET INDEX FIELD OF XCT
JUMPE R,.+2
HRRZ R,@UUOACS-1(R) ;IF NON-ZERO, GET CONTENTS OF THAT AC
ADD R,(TT) ;ADD IN ADDRESS FIELD
HLL R,(TT)
MOVEI TT,(R)
TLNE R,(@)
JRST UUOXCT ;MAKE INDIRECTION WIN
JRST UUOSB4 ;MAKE XCT OF XCT ... OF XCT OF UUO WIN
;;; TABLE OF WHERE TO FIND THE ACS AS THEY WERE ON UUO ENTRY
UUOACS:
IRPS X,,[A B C AR1 AR2A UUTSV UUTTSV D UURSV F FREEAC UUPSV FLP FXP SP]
X
TERMIN
UUOARR: HLRZ R,(T) ;*** ARRAY CALLED LIKE SUBR
MOVSI TT,(@)
JRST UUOS03
UUOS0: SETZ TT, ;*** SUBR CALLED LIKE SUBR
HRRZ R,UUOFN
UUOS03: MOVEM P,UUPSV ;THIS IS TO HELP UUOXCT
HLR TT,(T)
PUSH P,TT
LDB T,[270400,,40]
MOVNS T
PUSH FXP,T
PUSHJ P,ARGCHK ;SKIPS IF OK
JRST UUOS0E
POP FXP,R ;R NOW HAS -<# OF ARGS>
POP P,T
TLNN T,(@) ;FURTHER WORK NEEDED FOR CALLING AN ARRAY
JRST UUOSB3
MOVSI TT,TTS<CN>
HLL A,40 ;UUOSB7 WILL CLEAR LEFT HALF OF A
TLNN A,2000 ;DO NOT SET THE COMPILED-CODE-
IORM TT,TTSAR(T) ; NEEDS-ME BIT FOR A CALLF!
MOVE TT,40
TLZN TT,(20←33)
JRST UUOSB3
TLNN TT,(2←33)
JRST UUOAR2 ;NCALL'ING AN ARRAY MEANS CLOBBER,
PUSH P,[UUONVL] ; IF ANY, SHOULD BE TO ACALL
JRST UUOSB5
UUOAR2: TLNN TT,1000
TLOA T,(ACALL) ;NCALL, BUT NOT NCALLF => ACALL
TLOA T,(AJCALL) ;NJCALL, BUT NOT NJCALF => AJCALL
PUSH P,UUOH
TLZ TT,777000
TLZ T,(@)
JRST UUOSB6
UUONVL: SKOTT A,FX+FL
JRST UUONVE
FIX7: MOVE TT,(A) ;OF COURSE, THE ROUTINE HAD BETTER COME UP
POPJ P, ;WITH SOME LISP NUMBER AS VALUE
UUOS1E: PUSH FXP,D
MOVEI D,1
JRST UUOE3
UUOS2E: MOVEM D,(FXP) ;TAKE THE SPOT ALREADY PUSHED ON FXP
MOVEI D,3
UUOE3: PUSHJ P,SAVX3 ;ARGS WERE ALREADY ON PDL, HENCE MUST BE POPPED OFF
MOVEM B,QF1SB ;SO WE MIGHT AS WELL LIST THEM UP WHILE WE'RE AT IT
MOVE TT,T
JSP R,LIST1
MOVE T,TT
MOVE B,QF1SB
JRST UUOE2
UUOS0E: SUB P,R70+1
UUOS0F: PUSH FXP,D
PUSHJ P,SAVX3
MOVEI D,0
UUOE2: TLNE D,2 ;D 1.2 => EXIT ADDRESS ALREADY BEEN HACKED
JRST .+4
MOVE R,40
TLNN R,1000
PUSH P,UUOH
PUSHJ FXP,SAV5M1
PUSH P,[UUOSE1]
MOVE TT,40
HRLS TT
PUSH P,TT ;NAME OF FUNCTION IN LH
TRNN D,1 ;1.1 => LISTING HAS ALREADY BEEN DONE
JSP TT,ARGP0 ;ARGS TO FUNCTION NOW ON PDL
MOVEM D,-1(FXP)
PUSHJ P,RSTX3 ;RECUPERATE - IF POSSIBLE, DO NEW EVALUATION
JRST WNAERR ;OR ELSE CRAP OUT ON WRONG NUMBER ARGS
UUOSE1: PUSHJ FXP,RST5M1
POP FXP,D
POPJ P,
UUOS1: HRRZ TT,(T) ;*** SUBR CALLED LIKE LSUBR
HLRZ T,(T)
EXCH T,UUTSV
JSP R,PDLARG
HRRZ R,UUOFN
PUSHJ P,ARGCK0 ;FORCE CHECKING OF NUMBER OF ARGS
JRST UUOS0F
MOVE TT,40
TLNE TT,(20←33) ;THE NCALL BIT
AOS UUTSV
TLNN TT,(1←33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL
PUSH P,UUOH
JSR UUOBKG
JRST UUOXT1
UUOX4B: SKIPN UUOH ;=0 MEANS ENTRY FROM MAP SERIES
JRST (R)
PUSHJ FXP,SAV5M1
PUSH P,CR5M1PJ
JRST (R)
UUOLSB: MOVEM P,UUPSV ;*** LSUBR CALLED LIKE LSUBR
MOVEI A,NIL
HLRZ T,(T)
SKIPN V.RSET
JRST UUOSB2
PUSH FXP,T ;SAVE T (ADDRESS OF LSUBR)
MOVE T,UUTSV
PUSH FXP,T ;SAVE -<# OF ARGS> FOR UUOFUL
HRRZ R,UUOFN ;FOR ARGCK0
PUSHJ P,ARGCK0
JRST UUOS1E
MOVE R,T ;WATCH THIS SHUFFLING OF R, T, AND UUTSV!
JSP T,NPUSH-6 ;SIX SLOTS FOR "APPLY FRAME", ETC.
MOVE T,UUTSV
MOVEM R,UUTSV
MOVEI T,(P)
UUOLB3: AOJG R,UUOLB4 ;SO SLIDE STUFF SIX SLOTS UP THE PDL
MOVE TT,-6(T) ;AT END, T POINTS TO LAST OF THE FIVE
MOVEM TT,(T) ; FRAME SLOTS FOR UUOFUL
SOJA T,UUOLB3
UUOLB4: MOVE TT,40 ;FIGURE OUT IF CALL OR CALLF TYPE
MOVEI R,CPOPJ ; (MAY BE CALL TYPE IF 0 ARGS)
TLO R,(PUSHJ P,) ;FIGURE IT OUT
TLNE TT,1000 ;IT MAY LOOK LIKE WE'RE CONSTRUCTING A PUSHJ
TLCA R,(JRST#<PUSHJ P,>) ; TO THE WRONG PLACE, BUT READ THIS CAREFULLY!
HRR R,UUOH ;RETURN ADDRESS MUST GO UNDER
HRRZM R,-5(T) ; THE FRAME, NOT OVER!!!
HLLM R,-1(FXP) ;SAVE INSTRUCTION TO CLOBBER WITH
MOVEI TT,(T)
PUSHJ P,UUOFUL ;SO STICK AN APPLY FRAME UNDER ARGS, IF ANY
;REMEMBER, UUOFUL EXPECTS TWO FROBS
; ON FXP, AND POPS ONE OF THEM
POP FXP,T ;RESTORE T (ADDRESS OF LSUBR)
MOVE TT,40
JRST UUOSB7
UUOFUL: MOVS R,40 ;PUT FRAME UNDER LSUBR CALL
HRRI R,CPOPJ ;TT POINTS TO LAST OF 5 PDL SLOTS
MOVEM R,(TT) ;USES T,TT,R
MOVEI R,-2(FXP) ;FXP HAS -<# OF ARGS> AND ONE
HRRM R,-3(TT) ; OTHER SLOT AS WELL
HRLM FLP,-3(TT)
HRLM SP,-2(TT)
HRRZ R,40
HRRM R,-2(TT)
POP FXP,T
MOVEI R,(T)
HRLI R,-1(T)
ADDI R,(P)
SKIPN T
SETZ R,
MOVEM R,-4(TT)
MOVE R,[$APPLYFRAME]
MOVEM R,-1(TT)
POPJ P,
UUOS9: SKIPA TT,CILIST ;*** LSUBR CALLED LIKE FSUBR
UUOS7: MOVEI TT,ARGPDL ;*** LSUBR CALLED LIKE SUBR
MOVE R,40
TLNN R,1000
PUSH P,UUOH
HLRZ T,(T)
TLNE R,(20←33) ;THE NCALL BIT
ADDI T,1
PUSH FXP,T
PUSH FXP,XC-1
SKIPN V.RSET
JRST UUOS7A
MOVEI T,1
PUSHJ P,UUOBAK
REPEAT 2, SOS -3(P) ;ALLOW FOR TWO FROBS ON FXP
HRRZM P,(FXP)
UUOS7A: JSP TT,(TT) ;ARGPDL OR ILIST
POP FXP,R
JUMPL R,UUOS7K
SKIPN TT,T
JRST UUOS7H
HRLI TT,-1(TT)
ADDI TT,1(P)
UUOS7H: MOVEM TT,-4(R)
MOVE TT,[$APPLYFRAME]
MOVEM TT,-1(R) ;APPLYFRAME DONE
UUOS7K: MOVEM T,UUTSV
HRRZ R,UUOFN
PUSHJ P,ARGLCK
JRST UUOS2E
POP FXP,T
MOVEI A,0
JRST UUOXIT
UUOS2A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE FSUBR
MOVEM TT,LISAR
MOVEI R,(TT)
MOVEI TT,IAPAR1
JRST UUOS2Q
UUOS2: HLRZ TT,(T) ;*** SUBR CALLED LIKE FSUBR
HRRZ R,UUOFN
UUOS2Q: MOVE T,40
TLNN T,1000
PUSH P,UUOH
TLNE T,(NCALL)
PUSH P,[UUONVL]
CAIN T,IAPAR1
PUSH P,LISAR
PUSH FXP,TT ;SUBR ADDR
CILIST: JSP TT,ILIST ;ILIST FORTUNATELY SAVES R
PUSHJ P,ARGCHK
JRST UUOS2E
JSP R,PDLARG
POP FXP,TT ;PRESERVE T FOR UUOBKG
CAIN TT,IAPAR1
POP P,LISAR
JSR UUOBKG
MOVEI T,(TT) ;BEWARE! LOOSE SUBR POINTER
JRST UUOXIT
UUOS1A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE LSUBR
MOVEM TT,LISAR
MOVEI T,IAPAR1 ;HAIR SO INTERRUPTS WON'T SCREW US
EXCH T,UUTSV
JSP R,PDLARG ;SAVES TT
JSR UUOBKG ;ALSO SAVES TT, AND WANTS NOTHING ON PDLS
LDB R,[TTSDIM,,TTSAR(TT)]
MOVE TT,40
TLNN TT,1000
PUSH P,UUOH
TLNE TT,(NCALL)
PUSH P,[UUONVL]
MOVNI R,(R)
CAMN R,T
JRST UUOXT1
PUSH FXP,D
PUSHJ P,SAVX3
MOVEI D,2
JRST UUOE2
;;; PUTCODE [EXPR ← FSUBR]40
UUOS4: POP P,A ;*** FEXPR CALLED LIKE LSUBR
MOVN TT,UUTSV
JRST UUOS4A
UUF2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE FSUBR
UUOS6: HLRZ TT,(T) ;*** EXPR CALLED LIKE FSUBR
MOVE R,40
TLZN TT,-1 ;UUF2N LEAVES LH OF T ↑= 0
HRL TT,R ;OTHERWISE GET SUBR EXPR NAME IN LH
TLNN R,1000
PUSH P,UUOH
TLNE R,(20←33) ;THE NCALL BIT
PUSH P,[UUONVL]
JSP R,UUOX4B
SKIPN V.RSET
JRST UUOS6Q
PUSH P,FXP ;IF IN *RSET MODE, MAKE
HRLM FLP,(P) ; UP AN EVAL FRAME (SEE EVAL
MOVEI C,(A) ; FOR FORMAT THEREOF)
HRRZ B,40
PUSHJ P,XCONS ;MUST CONS UP FAKE ARG TO EVAL
PUSH P,A
HRLM SP,(P)
PUSH P,[$EVALFRAME]
MOVEI A,(C)
UUOS6Q: PUSH P,TT ;PUSH OF FUNCTION
MOVEI TT,IAPPLY
JRST ILIST
UUOS11: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE LSUBR
MOVE T,UUTSV
JRST UUS10A
;;; ENDCODE [EXPR ← FSUBR]
UUOS3: LDB TT,[270400,,40] ;*** FEXPR CALLED LIKE SUBR
UUOS4A: SOJN TT,UUOFER
UUOEX2: MOVEI TT,1 ;*** FEXPR CALLED LIKE FSUBR
DPB TT,[270400,,40]
TLOA A,400000
UUOS: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE SUBR
UUOEXP: HLRZ TT,(T) ;*** EXPR CALLED LIKE SUBR
LDB T,[270400,,40]
UUOEX4: MOVE R,40 ;ALL OF T,TT,R WILL BE LOST!
TLZN TT,-1 ;INSERT EXPR NAME IF WAS EXPR
HRL TT,R
TLNN R,1000
PUSH P,UUOH
MOVN T,T
SKIPE V.RSET
PUSHJ P,UUOBNC
TLNE R,(NCALL)
PUSH P,[UUONVL]
JSP R,UUOX4B
PUSH P,TT ;PUSH FUNCTION
JUMPE T,IAPPLY
MOVEM T,UUTSV
HRLZ R,UUTSV
MOVE A,1(R)
JSP T,PDLNMK
PUSH P,A ;PUSH ARGUMENT
AOBJN R,.-3
MOVE T,UUTSV
JRST IAPPLY ;APPLY FUN TO ARGS
UUOS10: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE SUBR
JSP TT,ARGPDL
UUS10A: AOJN T,UUOFER
POP P,A
MOVSI T,2000
IORM T,40
MOVE T,UUOFN
JRST UUOSBR
UUL2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE LSUBR
UUOS5: HLRZ TT,(T) ;*** EXPR CALLED LIKE LSUBR
MOVE T,UUTSV
CAMGE T,XC-NACS
JRST UUOS5A
JSP R,PDLARG
MOVNS T
JRST UUOEX4
UUOS5A: PUSH FXP,T ;DAMN CASE WHERE WE MUST
PUSH FXP,V.RSET ; SLIDE STUFF UP THE PDL,
MOVEI R,(P) ; DOING PDLNMK'S AS WE GO
JSP T,NPUSH-3-NACS+1 ;ROOM FOR ALL ACS BUT A, PLUS 3
SKIPE (FXP)
JSP T,NPUSH-5 ;EXTRA SLOTS FOR *RSET
MOVEI D,(P)
MOVE F,-1(FXP)
UUOS5B: MOVE A,(R) ;SO DO ALL THE PDLNMK'S
JSP T,PDLNMK
MOVEM A,(D)
SUBI R,1
SUBI D,1
AOJL F,UUOS5B
HRL TT,40 ;TT HAS BEEN SAVED - HAS FN
MOVEM TT,(D) ;SAVE FUNCTION BELOW ARGS FOR IAPPLY
SKIPE (FXP) ;D SHOULD POINT TO WHERE ACS ARE SAVED
SUBI D,5 ;FOR *RSET, MUST SAVE THE ACS UNDER THE FRAME!
REPEAT NACS-1, MOVEM B+.RPCNT,.RPCNT-NACS(D) ;SAVE ALL MARKED ACS BUT A
MOVEI TT,R5M1PJ ;PROVIDE FOR RESTORING THEM
MOVEM TT,-1(D) ;ACS WERE SAVED UNDER, NOT OVER, THE
MOVE TT,40 ; FRAME IN CASE OF AN FRETURN
MOVE F,UUOH ;MAYBE NEED RETURN ADDRESS UNDER
TLNE TT,1000 ; THE ARGS (IF NOT, USE A CPOPJ)
MOVEI F,CPOPJ
MOVEM F,-NACS-1(D)
POP FXP,F
JUMPE F,UUOS5C ;MAYBE MORE *RSET HAIR?
PUSH FXP,(FXP) ;DUPLICATE NUMBER OF ARGS ON FXP
MOVEI TT,4(D) ;TT POINTS TO THE FIVE *RSET SLOTS
MOVEM TT,-1(FXP) ;PLOP POINTER INTO PDL SLOT
PUSHJ P,UUOFUL ;SET UP APPLYFRAME (POPS FXP)
POP FXP,TT
HRRZS (TT) ;FLUSH CPOPJ - IAPPLY WILL CREATE ONE
JRST IAPPLY
UUOS5C: POP FXP,T ;NOW FOR THE IAPPLY
JRST IAPPLY ;UUOFUL WANTS TWO THINGS ON FXP, WILL POP ONE
ARGCHK: CAMGE T,XC-NACS ;CHECK NUMBER OF ARGS SUPPLIED
JRST PAERR ;R HAS ATOM PROPERTY LIST POINTER
ARGLCK: SKIPE V.RSET
JRST ARGCK2
ARGCK1: POP P,TT ;FOR SPEED, DO THIS RATHER THAN
JRST 1(TT) ;AOS (P) POPJ P,
ARGCK2: SKOTT R,SY ;R HAS SYMBOL OR SAR
JRST ARGCK5 ;MUST BE A SAR
ARGCK0: HLRZ R,(R)
HLRZ R,1(R)
JUMPE R,ARGCK1
LDB TT,[111100,,R]
JUMPN TT,ARGCK3
ARGCK4: LDB TT,[001100,,R]
MOVNI TT,-1(TT)
CAMN T,TT
AOS (P)
POPJ P,
ARGCK3: MOVNI TT,-1(TT)
CAMLE T,TT
POPJ P,
LDB TT,[001100,,R]
CAIN TT,777 ;777 IS EFFECTIVELY INFINITY
JRST POPJ1
MOVNI TT,-1(TT)
CAML T,TT
AOS (P)
POPJ P,
ARGCK5: LDB R,[TTSDIM,,TTSAR(R)]
AOJA R,ARGCK4
ARGPDL: LDB T,[270400,,40] ;ARGS => PDL -CNT=> T
MOVNS T
ARGP0: HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
PDLARG: CAMGE T,XC-NACS
PAERR: LERR EMS16 ;MORE THAN 5 ARGS
JRST .+1+NACS(T)
REPEAT NACS,[CONC RSTR,\<A-1+NACS-.RPCNT>,: POP P,A-1+NACS-.RPCNT
]
PDLA2: JRST (R)
MOVEI D,QSUBRCALL ;COME HERE IF SUBRCALL (Q.V.) GOT 0 ARGS
SOJA T,WNALOSE
STRTOUT: MOVE T,UUTSV
PUSH P,UUOH
PUSH P,A
PUSHJ P,SAVX5
PUSH FXP,40
IFN QIO,[
PUSH P,AR1
PUSH P,AR2A
LDB D,[270400,,(FXP)] ;AC=17 MEANS USE MSGFILES.
CAIN D,17
JRST ERP0D
SKIPN AR1,(D) ;NIL MEANS USE DEFAULT ↑R AND ↑W
JRST ERP0C
ERP0E: TLO AR1,200000
ERP0F: MOVEI A,(AR1)
LSH A,-SEGLOG
SKIPL ST(A) ;MAYBE SHOULD ERRR-CHECK BETTER?
TLO AR1,400000 ;NOTE WHETHER LIST OR NOT
ERP0A: JSP T,GTRDTB
.5LOCKI
ERBPLOC==-1 ;LOCATION OF BYTE PTR ON FXPDL
] ;END OF IFN QIO
IFE QIO, ERBPLOC==0
MOVSI D,440600
HLLM D,ERBPLOC(FXP)
ERP1: ILDB TT,ERBPLOC(FXP) ;STRING BYTE POINTER IS STORED ON FXP
CAIN TT,'# ;THE .5LOCKI SAVED INHIBIT ON TOP OF FXP
JRST ERP3
CAIN TT,'!
JRST ERP6
CAIN TT,'↑
JRST ERP4
ERP5: ADDI TT,40
ERP5A: PUSHJ P,STRTYO
JRST ERP1
IFN QIO,[
ERP0D: SKIPN AR1,VMSGFILES
JRST ERP6A
JRST ERP0E
ERP0C: SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
JUMPN AR1,ERP0F
SKIPE TTYOFF
JRST ERP6A
JRST ERP0A
] ;END OF IFN QIO
ERP3: ILDB TT,ERBPLOC(FXP) ;QUOTE A CHAR
JRST ERP5
ERP4: ILDB TT,ERBPLOC(FXP) ;CONTROLLIFY A CHAR
ADDI TT,40
TRC TT,100
Q$ CAIE TT,↑M
JRST ERP5A
Q$ PUSHJ P,STRTYO
Q$ MOVEI TT,↑J
Q$ JRST ERP5A
ERP6:
IFN QIO,[
UNLOCKI ;DONE!
ERP6A: POP P,AR2A
POP P,AR1
] ;END OF IFN QIO
SUB FXP,R70+1 ;FLUSH BYTE PTR
POP P,A ;RESTORE A
JRST RSTX5 ;RESTORE NUMACS AND POPJ
ENDFUN==.-1 .SEE SSYSTEM ;NO MORE FUNCTIONS BEYOND HERE
SUBTTL INITIAL STARTUP CODE
LISP:
IFN USELESS*<1-D10>, JSP T,SHAREP
10% Q% SETZM LPTOPD
Q% SETZM UTOOPD ;NORMAL REENTRY POINT
Q% SETZM UTIOPD ;COME HERE FROM LISPGO
IFN MOBIOF,[
SETZM FTVU
SETZM BVDOPD
SETZM NVDOPD
SETZM DISOPD
SETZM DISPON
] ;END OF IFN MOBIOF
SETZM TAPWRT
SETZM TTYOFF
REPEAT NFF, SETZM FFS+.RPCNT ;SET FREELISTS TO NIL
IFN HNKLOG, MOVSI A,(SETZ)
REPEAT HNKLOG,[
SKIPN HNSGLK+.RPCNT ;HACK TO AVOID CREATING
MOVEM A,FFH+.RPCNT ; UNNEEDED HUNK SEGMENTS
] ;END OF REPEAT HNKLOG
SETZM GCTIM
SETZM ALGCF
IFN ITS,[
.SUSET [.SPIRQC,,R70]
.SUSET [.SIFPIR,,R70]
IFE QIO,[
SETZM LPTON
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFE QIO
.SUSET [.ROPTION,,TT]
Q$ TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
Q$ .SUSET [.SOPTION,,TT]
TLNN TT,OPTBRK
JRST LISP17
.BREAK 12,[..RSTP,,TT] ;READ SYMBOL TABLE POINTER
JUMPGE TT,LISP17
.VALUE [ASCIZ /↔..TAMP\
..TPER\≠1Q
..TAMP\P%
:VP /]
LISP17:
] ;END OF IFN ITS
JSP A,ERINIT ;SETS UP PDLS AND I/O SWITCHES
JSP T,TLVRSS
IFN EDFLAG, SETOM EDPRFL
IFN ITS,[
Q% .SUSET [.SMASK,,INTMSK]
Q$ INTON
Q% MOVE TT,IUSN
Q% MOVEM TT,USN
Q% .SUSET [.SSNAM,,USN]
Q% PUSHJ P,TTYOPN
Q$ MOVE TT,IUSN
Q$ MOVEM TT,TTYIF2+F.SNM
Q$ MOVEM TT,TTYOF2+F.SNM
IFN JOBQIO,[
.DTTY
JFCL
] ;END OF IFN JOBQIO
Q$ PUSHJ P,OPNTTY
JFCL
MOVSI T,111111
PUSHJ P,GCNRT
.CALL LISP43
.VALUE
Q% PUSHJ P,SUNAM1
Q$ PUSHJ P,SIXATM
HRLM A,MACHFT ;SET UP (STATUS FEATURES) FOR MACHINE NAME
] ;END OF IFN ITS
;;; FALLS THRU
;;; FALLS THRU
IFN D10,[
MOVEI TT,INT0
MOVEM TT,.JBAPR"
MOVEI TT,630000
APRENB TT,
MOVEI A,IN0+72.
MOVEM A,VLINEL
MOVEM A,OLINEL
] ;END OF IFN D10
MOVE TT,BPSH
CAMGE TT,@VBPEND
PUSHJ P,BPNDST
IFN D10,[
MOVEI T,TTYINT
MOVEM T,.JBREN"
SETOM UPCOK
PUSHJ P,GCNRT
SA$ SETZ T,
SA$ CALLI T,400071
SA% GETPPN T,
SA% JFCL
MOVEM T,USN
MOVE F,[4,,T]
MOVNI T,1
SETZB TT,D
MOVEI R,0
SA% PATH. F,
MOVE D,USN ;FAILED
PUSHJ P,SUNM2
] ;END OF IFN D10
;FALLS THROUGH
;FALLS IN
IFE D10,[
Q% MOVE A,[440600,,USN] ;SAME AS IUSN (SEE ABOVE)
IFN QIO,[
PUSH FXP,IUSN
PUSH FXP,R70
MOVEI A,-1(FXP)
HRLI A,440600
] ;END OF IFN QIO
PUSHJ P,READ6C
Q$ SUB FXP,R70+2
] ;END OF IFE D10
MOVEM A,SUDIR
IFE QIO,[
PUSHJ P,NCONS
MOVEI B,QDSK
PUSHJ P,XCONS
MOVEM A,IUNIT ;INSTALL CURRENT USER IN IUNIT
MOVEI T,<↑C>←13
HRLZM T,UTIB+UTBSIZ
] ;END OF IFE QIO
IFN MOBIOF, PUSHJ P,CLSSIX
MOVEI T,INR70 ;LOCATION OF LAP CONSTANTS
MOVEM T,VTTSR
MOVEI A,Q. ;INITIAL VALUE OF * IS *
MOVEM A,V.
MOVE A,VERRLIST ;SET UP FOR EVAL'ING ERRLIST
MOVEM A,VIQUOTIENT
PION ;ENABLE INTERRUPTING
SKIPGE AFILRD
JRST LSPRET
LIHAC:
Q% AOS UTIOPD ;HAIRY HAC TO READ, THE FIRST TIME
SETOM AFILRD ; AROUND, FROM THE .LISP. (INIT) FILE
MOVEI A,TRUTH
MOVEM A,TAPRED
JRST HACENT
IFN ITS,[
LISP43: SETZ
SIXBIT \SSTATU\
REPEAT 5, 2000,,TT ;IGNORE USELESS GARBAGE
Q% 402000,,UNMTMP ;MACHINE NAME
Q$ 402000,,TT ;MACHINE NAME
IFE QIO,[
TTYOPN: .OPEN TYIC,OTYIC
.VALUE
.OPEN TYOC,OTYOC
.VALUE
.CALL RTTYS
.VALUE
TLO R,%TS<CLE+ACT+MOR>
MOVEM R,STTYSS
.CALL CNSGT1
.VALUE
ANDI TT,777
IOR D,TT
MOVEM D,TTYDISP
MOVEM D,SRNLN1
MOVEI A,IN0(TT) ;A NUMBER FOR TTY TYPE
MOVEM A,VTTY ; (GUARANTEED NLISP INUM)
JSP T,WAKTTY
.CALL RSSBLK ;WANT TO LEAVE IN ACC TT THE WIDTH OF THE SCREEN IN CHARS
.VALUE
SUBI TT,1 ;LINE LENGTH RETURNED BY SYSTEM MAY BE 2 TOO LONG
SUBI D,1
SKIPE SRNLN1
MOVEM D,SRNLN1
CAILE TT,777 ;CONCEIVABLY THE LINEL IS SET HUGE
MOVEI TT,777
MOVEI A,IN0(TT) ;SET UP LINEL (GUARANTEED NLISP INUM)
MOVEM A,VLINEL
MOVEM A,OLINEL
POPJ P,
CNSGT1: SETZ
SIXBIT \CNSGET\
1000,,TYIC
2000,,TT
2000,,TT
2000,,TT
2000,,D
402000,,D
OTYIC: (SIXBIT \TTY\)
SIXBIT \.LISP.\
SIXBIT \INPUT\
OTYOC: (21+SIXBIT \TTY\)
SIXBIT \.LISP.\
SIXBIT \OUTPUT\
RSSBLK: SETZ
SIXBIT \RSSIZE\
1000,,TYIC
2000,,TT+1 ;SCREEN HEIGHT
402000,,TT ;SCREEN WIDTH (LINEL)
RTTYS: SETZ
SIXBIT \TTYGET\
1000,,TYIC
2000,,TT ;TTYST1 (WORD ONE CHARACTER BITS)
2000,,D ;TTYST2 (WORD TWO)
402000,,R ;TTYSTS
WAKTTY: .CALL STTYS
.VALUE
JRST (T)
STTYS: SETZ
SIXBIT \TTYSET\
1000,,TYIC
STTYS1 ;TTYST1
STTYS2 ;TTYST2
400000,,STTYSS ;TTYSTS
] ;END OF IFE QIO
] ;END OF IFN ITS
10$ WAKTTY: JRST (T)
IFN ITS,[
Q% TMPC==DSIC
NOSHARE==JRST (T) ;DEPOSIT INTO SHAREP TO INHIBIT SHAREING
SHAREP: SKIPN SAWSP
JRST (T)
SETZM SAWSP
.CALL PURCHK
.VALUE
JUMPLE TT,(T)
.OPEN TMPC,SYSFIL
JRST (T)
.ACCESS TMPC,[2000+BPURPG]
MOVE TT,[-NPURPG,,BPURPG/PAGSIZ]
.CALL PURPGS ;SHARE PURE CODE
.VALUE
.ACCESS TMPC,[2000+BPURFS-<NXVCSG+NXXZSG>*SEGSIZ]
MOVE TT,[-NPURFS,,BPURFS/PAGSIZ]
.CALL PURPGS ;SHARE PURE DATA AREAS
.VALUE
.CLOSE TMPC,
JRST (T)
PURCHK: SETZ
SIXBIT \CORTYP\ ;GET TYPE FOR CORE BLOCK
1000,,BPURPG/PAGSIZ ;LOWEST PURE BLOCK
402000,,TT ;>0 READ-ONLY, <0 WRITABLE
SYSFIL: SIXBIT \ &SYS\ ;FOR OPENING UP FILE TO SHARE
Q% SIXBIT \PURBIB\
Q$ SIXBIT \PURQIO\
LVRNO
PURPGS: SETZ
SIXBIT \CORBLK\ ;HACK CORE BLOCKS
1000,,200000 ;GET READ-ONLY PAGES
1000,,-1 ;PUT THEM INTO *MY* PAGE MAP
,,TT ;AOBJN POINTER FOR PAGES
401000,,TMPC ;DISK FILE TO SHARE WITH
] ;END OF IFN ITS
SUBTTL INTERNAL PCLSR'ING ROUTINES
SFXTBL: ;TABLE OF LOCATIONS FOR SFX HACK
MACROLOOP NSFC,ZZM,*
SFXTBI: ;TABLE OF INSTRUCTIONS NORMALLY IN THOSE LOCATIONS
MACROLOOP NSFC,ZZN,*
PROTB: ;TABLE OF INTERRUPT PROTECTION INTERVALS
MACROLOOP NPRO,PRO,*
;;; TABLE MUST BE AN EXACT POWER OF TWO IN LENGTH SO WE CAN
;;; USE SUPER-WINNING BINARY SEARCH METHOD.
HAOLNG LOG2NPRO,<.-PROTB-1>
REPEAT <1←LOG2NPRO>-NPRO,[ INTOK,,777777
] ;END OF REPEAT <1←LOG2NPRO>-NPRO
;;; IT IS OBVIOUSLY USELESS TO USE PROTECT MACROS BEYOND THIS POINT.
;;; EXPUNGING NPRO WILL CAUSE AN ERROR IF THE PROTECT MACROS ARE USED
EXPUNGE NPRO
IFE QIO,[
;INTWAIT: 0
INTW0: MOVEM C,QITC ;.SUSET PIHOLD TO BE DONE BEFORE ENTERING
MOVEM D,QITD ; (INTERRUPT ENTRY IN EFFECT IS A PIHOLD)
MOVEM R,QITR
SKIPE WAITFL
JRST INTW4 ;BUSY DOING SFX HACK - GO STACK UP INTERRUPT
HLRZ C,NOQUIT ;IF IN GC, NEEDN'T CHECK SP - IT WILL
JUMPN C,INTW1 ; UNDOUBTEDLY BE IN STRANGE STATE ANYWAY
MOVE C,(SP) ;ALLOWS SPDL TO GET CAUGHT UP,
MOVEI D,(SP) ; OR CONSER TO FINISH HIS EXCH'S,
CAME D,ZSC2 ; BUT SKIPS 1 IF IN GC
CAMN C,SPSV ; (LH OF NOQUIT NONZERO)
JRST INTW1
INTSFX: SETOM WAITFL ;SET FLAG FOR SFX HACKERY
MOVEM A,WAITA ;SAVE A
MOVE A,INT
MOVE D,[JSR SPWR]
MOVSI R,-NSFC
MOVEM D,@SFXTBL(R) ;CLOBBER LOCATIONS MARKED BY SFX SO
AOBJN R,.-1 ; SFXPRO'ED ROUTINE WILL RETURN HERE
MOVE D,QITD ;RESTORE ACS
MOVE C,QITC
MOVE R,QITR
IFN ITS,[
.SUSET [.SDF1,,[<-1>#<IB.PDLOV+IB.MPV+IB.ILOP+IB.PUR>]]
.SUSET [.RDF2,,WAITD2] ;DEFER MOST NON-NASTY INTERRUPTS
.SUSET [.SDF2,,XC-1]
.DISMISS IPCLOK ;ENABLE INTERRUPTS IN CASE OF PDL OVERFLOW, ETC.
] ;END OF IFN ITS
10$ JRST 2,@IPCLOK
10X WARN [INTERRUPT RETURN IN TENEX]
;;; IFE QIO
;SPWR: 0
SPWR0: PIOF
IFN ITS,[
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,WAITD2]
] ;END OF IFN ITS
MOVEM R,QITR
MOVEM C,QITC ;SAVE ACS
MOVEM D,QITD
MOVEM A,INT
MOVE A,WAITA
MOVSI R,-NSFC
MOVE D,SFXTBI(R) ;RESTORE LOCATIONS CLOBBERED BY JSR'S
MOVEM D,@SFXTBL(R)
AOBJN R,.-2
SOS C,SPWR ;BACK UP PC TO CLOBBERED INSTRUCTION
MOVEM C,IPCLOK
SETZM WAITFL ;SURVIVED SFX HACK - EVERYTHING'S HAPPY
JRST INTW2
INTW1: HRRZ C,IPCLOK
JUMPE C,INTOK
MOVEI D,0 ;FAST BINARY SEARCH OF PROTECT TABLE
REPEAT LOG2NPRO,[
MOVE R,PROTB+<1←<LOG2NPRO-.RPCNT-1>>(D)
CAIL C,(R)
ADDI D,1←<LOG2NPRO-.RPCNT-1>
] ;END OF REPEAT LOG2NPRO
HLRZ R,PROTB(D)
JRST (R) ;GO TO PLACE WHICH HANDLES THIS INTERVAL
INTXCT: MOVE R,QITR ;RESTORE ACS
MOVE D,QITD
MOVE C,QITC
EXCH A,INT ;NOTE: FLAGS ARE NOT RESTORED
XCT @IPCLOK ;EXECUTE AN INSTRUCTION
JRST .+2
AOS IPCLOK ;HANDLE SKIPS CORRECTLY - SEE UUOACL
AOS IPCLOK
MOVEM C,QITC
MOVEM D,QITD
MOVEM R,QITR
EXCH A,INT
JRST INTW1 ;TRY AGAIN - MAYBE MORE TO XCT
;;; IFE QIO
INTSYP: SOS NPFFY2 ;PROTECT SYMBOL CONSER
INTSYQ: SOS NPFFY2
INTSYX: MOVEI C,SYCONS
JRST INTBK1
INTROT: MOVE C,PROTB(D) ;PROTECT CODE OF THE FORM
SUBI C,1 ; ROT A,-SEGLOG
HRRM C,IPCLOK ; ... MUNCH ...
EXCH A,INT ; ROT A,SEGLOG
ROT A,SEGLOG
EXCH A,INT
JRST INTOK
INTPPC: MOVE C,PROTB(D) ;PROTECT PURE CONSER
SUBI C,1 ;BACK UP TO THE AOSL OR WHATEVER
HRRM C,IPCLOK
SOS @(C) ;RESTORE THE COUNTER
JRST INTOK
INTC2X: HLRM B,INT ;MUST PROTECT LEFT HALF OF B FOR CONS
MOVEI C,CONS1 ;HAIRY KIND OF BACKUP FOR CONS
JRST INTBK1
INTACT: HRRZ C,UUTSV ;UUOACL
JRST INTW1
IFE QIO,[
INTTYI: MOVEI C,TYIN ;PROTECTS THE CASE OF PTYBF FILLED
JRST INTBK1 ; WHEN INTERRUPTED FROM TTYTYI
] ;END OF IFE QIO
INTZAX: SETZM INT ;FOR CONSERS WHICH DON'T WANT TO PROTECT THEIR FREELIST!
INTACX: MOVSS INT ;FOR ACONS (RESTORES A FOR BACKUP)
INTBAK: MOVE C,PROTB(D) ;BACK UP PC TO BEGINNING
INTBK1: HRRM C,IPCLOK ; OF INTERVAL
INTOK:
10$ CAIL C,400000 ;NO ARRAYS IN HIGH SEGMENT!
10$ JRST INTW2
CAML C,@VBPEND
JRST INTSFX
INTW2: HLRZ C,NOQUIT
JUMPE C,INTW5
INTW4: AOS C,INTWAIT ;GC IS IN PROGRESS - CAUSES SKIP UPON EXIT
MOVEI C,(C)
CAIN C,INTW3
SKIPN @UINTTB(A)
JRST INTW5
MOVE D,QITD ;MUST RESTORE D AND R SO UISTAK
MOVE R,QITR ; CAN SAVE THEM AGAIN
JSR UISTAK ;STACK UP, IF PI IS USER-ENABLED
INTW5: MOVE D,QITD ;RESTORE ACS
MOVE R,QITR
MOVE C,QITC
JRST 2,@INTWAIT ;RETURN TO CALLER
] ;END OF IFE QIO
IFN QIO,[
;;; PUSHJ FXP,IWAIT
;;; CALLED FROM WITHIN A NORMAL INTERRUPT HANDLER TO DECIDE
;;; WHETHER IT IS SAFE TO ISSUE A USER INTERRUPT.
;;; ON FAILURE, STACKS UP THE INTERRUPT AND SKIPS.
;;; AS FOR UINT0, D CONTAINS THE INTERRUPT DESCRIPTOR WORD.
;;; INTERRUPTS MUST BE DEFERRED; PDL OVERFLOW MUST BE
;;; ENABLED. THE CONTENTS OF INTPDL POINTS TO THE INTPDL ENTRY
;;; FOR THE CURRENT INTERRUPT, WHICH CONTAINS THE SAVED
;;; CONTENTS OF D AND R. FXP MUST BE IN A USABLE STATE.
IWAIT: HLRZ R,NOQUIT ;IF IN GC, WE ARE IN A BAD STATE
JUMPN R,IWSTAK ; AND SO MUST STACK THE INTERRUPT
MOVEI R,(SP) ;IF THE SPECPDL IS IN SOME
MOVE F,(SP) ; KIND OF STRANGE STATE (E.G.
CAME R,ZSC2 ; INTERRUPTED OUT OF SPECBIND)
CAMN F,SPSV ; THEN MUST DO THE INTSFX HACK
JRST IWLOOK
INTSFX: MOVE F,[PUSHJ FXP,SPWIN]
MOVSI R,-NSFC
MOVEM F,@SFXTBL(R) ;CLOBBER LOCATIONS MARKED BY SFX SO
AOBJN R,.-1 ; SFXPRO'ED ROUTINE WILL RETURN TO SPWIN
HRRZ F,INTPDL ;RESTORE AC'S, AND SAVE
EXCH D,IPSWD2(F) ; INTERRUPT DESCRIPTOR
MOVE R,IPSWD1(F)
PUSH FXP,IPSPC(F) ;GET PC AND FLAGS
MOVE F,IPSF(F)
JRST 2,@(FXP) ;CONTINUE WHATEVER WE WERE DOING
;;; IFN QIO
;;; RETURN FROM SFX HACK. ROUTINE HAS DONE PUSHJ FXP,SPWIN.
SPWIN: HRRZ F,INTPDL
POP FXP,IPSPC(F) ;PUT PC BACK INTO INTPDL FRAME,
SOS IPSPC(F) ; BACKED UP TO THE CLOBBERED INSTRUCTION
SUB FXP,R70+1
MOVEM R,IPSWD1(F) ;SAVE AC'S
EXCH D,IPSWD2(F)
MOVSI R,-NSFC
SPWIN1: MOVE F,SFXTBI(R) ;RESTORE THE LOCATIONS THAT WE
MOVEM F,@SFXTBL(R) ; CLOBBERED WITH PUSHJ FXP,SPWIN
AOBJN R,SPWIN1
JRST IWWIN ;WE HAVE WON
IWLOOK: HRRZ F,INTPDL ;FAST BINARY SEARCH OF PROTECT
HRRZ R,IPSPC(F) ; TABLE ON PC INTERRUPTED FROM
PUSH FXP,D
MOVEI D,0
REPEAT LOG2NPRO,[
MOVE F,PROTB+<1←<LOG2NPRO-.RPCNT-1>>(D)
CAIL R,(F)
ADDI D,1←<LOG2NPRO-.RPCNT-1>
] ;END OF REPEAT LOG2NPRO
MOVS R,PROTB(D)
POP FXP,D
HRRZ F,INTPDL ;A USEFUL VALUE FOR F
JRST (R) ;GO TO PLACE WHICH HANDLES THIS INTERVAL
INTXCT: PUSH FXP,IPSPC(F)
EXCH D,IPSWD2(F) ;RESTORE AC'S
MOVE R,IPSWD1(F) ;FLAGS ARE *NOT* RESTORED
MOVE F,IPSF(F) ; ALSO, FXP IS OUT OF WHACK
XCT @(FXP) ;EXECUTE AN INSTRUCTION
JRST .+2
AOS (FXP) ;HANDLE SKIPS CORRECTLY
AOS (FXP) .SEE UUOACL
HRRZ F,INTPDL
MOVEM R,IPSWD1(F)
EXCH D,IPSWD2(F)
POP FXP,IPSPC(F)
JRST IWLOOK ;MAY NEED TO XCT SOME MORE
;;; IFN QIO
INTSYP: SOS NPFFY2 ;PROTECT SYMBOL CONSER
INTSYQ: SOS NPFFY2
INTSYX: MOVEI R,SYCONS
JRST INTBK1
INTROT: HLRZ R,R ;PROTECT CODE OF THE FORM
SUBI R,1 ; ROT A,-SEGLOG
ROT A,SEGLOG ; ... MUNCH ...
JRST INTBK1 ; ROT A,SEGLOG
INTPPC: HLRZ R,R ;PROTECT PURE CONSER
SUBI R,1 ;BACK UP TO THE AOSL OR WHATEVER
HRRM R,IPSPC(F)
SOS @(R) ;RESTORE THE COUNTER
JRST INTOK
INTC2X: HLRM B,A ;MUST PROTECT LEFT HALF OF B FOR CONS
MOVEI R,CONS1 ;HAIRY KIND OF BACKUP FOR CONS
JRST INTBK1
INTACT: HRRZ R,UUTSV ;UUOACL
JRST IWLOOK
INTTYY: SKIPA R,[INTTYS] ;PROTECTS $DEV4J
INTTYX: MOVEI R,INTTYR ;PROTECTS TYOTYI
HRRZS INHIBIT .SEE .5LKTOPOPJ
JRST INTBK1
INTZAX: TDZA A,A ;FOR CONSERS WHICH DON'T WANT TO PROTECT THEIR FREELIST!
INTACX: MOVSS A ;FOR ACONS (RESTORES A FOR BACKUP)
INTBAK: HLRZ R,R ;BACK UP PC TO BEGINNING
INTBK1: HRRM R,IPSPC(F) ; OF INTERVAL
INTOK: TLZ R,-1
10$ CAIL R,400000 ;NO ARRAYS IN HIGH SEGMENT!
10$ JRST IWWIN
CAML R,@VBPEND
JRST INTSFX
IWWIN: HRRZ F,INTPDL ;WE HAVE WON!
POPJ FXP,
;;; NEED WE PIOF AROUND THIS JSR UISTAK ??
IWSTAK: JSR UISTAK ;WE ARE IN A BAD STATE --
AOS (FXP) ; STACK UP THE INTERRUPT
JRST IWWIN
] ;END OF IFN QIO
PGTOP INT,[INTERRUPT AND UUO HANDLERS]
SUBTTL STRUCT INSERT, BIT TABLES, AND SPACE CALCULATIONS
IFE LOPATCH,[
EXPUNGE PATCH PAT XPATCH
PATCH: PAT: XPATCH: BLOCK PTCSIZ
EPATCH==.-1
] ;END OF IFE LOPATCH
PAGEUP
10$ BSYSSG==HILOC-STDHI ;CROCK - BEWARE RELOCATION!
SPCTOP SYS,,[SYSTEM]
10$ EXPUNGE BSYSSG
NPURPG==<.-BPURPG>/PAGSIZ
10$ $LOSEG
INUM==.
$INSRT STRUCT ;INITIAL LIST STRUCTURE
;;; 10$ NOW IN ** LOW SEGMENT **
NBITB==NIFSSG+NIFXSG+NIFLSG+NBNSG
ZZ==<<NBITB+1>*BTBSIZ+SEGSIZ-1>/SEGSIZ
IFN ZZ-BTSGGS,[
WARN [NEEDED NUMBER OF INITIAL BIT TABLE SEGMENTS (]\ZZ,[) DOESN'T
MATCH GUESS. (BTSGGS=]\BTSGGS,[)
]
] ;END OF IFN ZZ-BTSGGS
.ALSO .ERR
IFN LOBITSG, BFBTBS=BTBLKS+NBITB*BTBSIZ
.ELSE,[ ;;; NOTE WELL! FIRST FS SEGMENT GETS FIRST
;;; BIT BLOCK! (SEE NUNMRK, GCP6)
SPCBOT BIT
BTBLKS: BLOCK NBITB*BTBSIZ
BFBTBS: ;BEGINNING OF FREE BIT BLOCKS
PAGEUP
SPCTOP BIT,ST,[BIT BLOCK]
] ;END OF .ELSE
NBPSSG==1*SGS%PG ;INIT WILL MUNG ST AND PURTBL ANYWAY TO PRESERVE ALLOC
NFXPSG==1*SGS%PG ;PDL AREAS FOR INIT AND ALLOC
NFLPSG==1*SGS%PG
NPSG==1*SGS%PG
NSPSG==1*SGS%PG ;ALLOC ALTERS ALL PDL PARAMETERS!!!
IFN ITS,[
NXFXPSG==1*SGS%PG
NXFLPSG==1*SGS%PG
NXPSG==1*SGS%PG
NXSPSG==1*SGS%PG
IFN ML+QIO, NSCRSG==2*SGS%PG
.ELSE NSCRSG==3*SGS%PG ;ALLOW FOR PDP6 PAGE (P6)
;;; NUMBER OF NON-EXISTENT MEMORY SEGMENTS
;;; (TAKE ALL OF CORE AND SUBTRACT OUT EVERYTHING USEFUL!!!)
NNXMSG==NSEGS
IRP SPC,,[ZER,ST,SYS,SAR,VC,XVC,IS2,SYM,XXA,XXZ,SY2,PFX,PFS,PFL,XXP
IFS,IFX,IFL,BN,XXB,BIT,BPS,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
NNXMSG==NNXMSG-N!SPC!SG
TERMIN
;;; DETERMINE ORIGINS FOR ALL SPACES ABOVE THIS POINT
ZZX==.
IRP SPC,,[BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN
SPDLORG==MEMORY-<NSCRSG+NSPSG+NXSPSG>*SEGSIZ
PDLORG==SPDLORG-<NPSG+NXPSG>*SEGSIZ
FLPORG==PDLORG-<NFLPSG+NXFLPSG>*SEGSIZ
FXPORG==FLPORG-<NFXPSG+NXFXPSG>*SEGSIZ
] ;END OF IFN ITS
IFE ITS,[
ZZX==.
IRP SPC,,[FXP,FLP,P,SP,BPS]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN
SPDLORG==BSPSG
PDLORG==BPSG
FLPORG==BFLPSG
FXPORG==BFXPSG
] ;END OF IFE ITS
SUBTTL APOCALYPSE (END OF THE WORLD)
;FOR REL ASSEMBLIES, INIT AND ALLOC CODE OVERLAP INITIAL BPS
IFE ITS, LOC BBPSSG
$INSRT ALLOC ;INITIALIZATION AND ALLOCATION ROUTINES
PRINTX \
\ ;JUST TO MAKE LSPTTY LOOK NICER
EXPUNGE ZZ ZY ZX ZZX ZZY ZZZ ZZW
10$ IF2, BSYSSG==400000 ;ANTI-RELOCATION CROCK
IF2, MACROLOOP NBITMACS,BTMC,* ;FOR BIT TYPEOUT MODE
CONSTANTS ;FOR ALLOC
ENDLISP==. ;END OF LISP, BY GEORGE!
VARIABLES ;NO ONE SHOULD USE VARIABLES!
IFN .-ENDLISP, WARN [OKAY, WHO'S THE WISE GUY USING VARIABLES?]
END INIT